      SUBROUTINE MB03KA( COMPQ, WHICHQ, WS, K, NC, KSCHUR, IFST, ILST,
     $                   N, NI, S, T, LDT, IXT, Q, LDQ, IXQ, TOL, IWORK,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To reorder the diagonal blocks of the formal matrix product
C
C        T22_K^S(K) * T22_K-1^S(K-1) * ... * T22_1^S(1),             (1)
C
C     of length K, in the generalized periodic Schur form
C
C              [  T11_k  T12_k  T13_k  ]
C        T_k = [    0    T22_k  T23_k  ],    k = 1, ..., K,          (2)
C              [    0      0    T33_k  ]
C
C     where
C
C     - the submatrices T11_k are NI(k+1)-by-NI(k), if S(k) = 1, or
C       NI(k)-by-NI(k+1), if S(k) = -1, and contain dimension-induced
C       infinite eigenvalues,
C     - the submatrices T22_k are NC-by-NC and contain core eigenvalues,
C       which are generically neither zero nor infinite,
C     - the submatrices T33_k contain dimension-induced zero
C       eigenvalues,
C
C     such that the block with starting row index IFST in (1) is moved
C     to row index ILST. The indices refer to the T22_k submatrices.
C
C     Optionally, the transformation matrices Q_1,...,Q_K from the
C     reduction into generalized periodic Schur form are updated with
C     respect to the performed reordering.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPQ   CHARACTER*1
C             = 'N': do not compute any of the matrices Q_k;
C             = 'U': each coefficient of Q must contain an orthogonal
C                    matrix Q1_k on entry, and the products Q1_k*Q_k are
C                    returned, where Q_k, k = 1, ..., K, performed the
C                    reordering;
C             = 'W': the computation of each Q_k is specified
C                    individually in the array WHICHQ.
C
C     WHICHQ  INTEGER array, dimension (K)
C             If COMPQ = 'W', WHICHQ(k) specifies the computation of Q_k
C             as follows:
C             = 0:   do not compute Q_k;
C             > 0:   the kth coefficient of Q must contain an orthogonal
C                    matrix Q1_k on entry, and the product Q1_k*Q_k is
C                    returned.
C             This array is not referenced if COMPQ <> 'W'.
C
C     WS      LOGICAL
C             = .FALSE. : do not perform the strong stability tests;
C             = .TRUE.  : perform the strong stability tests; often,
C                         this is not needed, and omitting them can save
C                         some computations.
C
C     Input/Output Parameters
C
C     K       (input) INTEGER
C             The period of the periodic matrix sequences T and Q (the
C             number of factors in the matrix product).  K >= 2.
C             (For K = 1, a standard eigenvalue reordering problem is
C             obtained.)
C
C     NC      (input) INTEGER
C             The number of core eigenvalues.  0 <= NC <= min(N).
C
C     KSCHUR  (input) INTEGER
C             The index for which the matrix T22_kschur is upper quasi-
C             triangular. All other T22 matrices are upper triangular.
C
C     IFST    (input/output) INTEGER
C     ILST    (input/output) INTEGER
C             Specify the reordering of the diagonal blocks, as follows:
C             The block with starting row index IFST in (1) is moved to
C             row index ILST by a sequence of direct swaps between adjacent
C             blocks in the product.
C             On exit, if IFST pointed on entry to the second row of a
C             2-by-2 block in the product, it is changed to point to the
C             first row; ILST always points to the first row of the block
C             in its final position in the product (which may differ from
C             its input value by +1 or -1).
C             1 <= IFST <= NC, 1 <= ILST <= NC.
C
C     N       (input) INTEGER array, dimension (K)
C             The leading K elements of this array must contain the
C             dimensions of the factors of the formal matrix product T,
C             such that the k-th coefficient T_k is an N(k+1)-by-N(k)
C             matrix, if S(k) = 1, or an N(k)-by-N(k+1) matrix,
C             if S(k) = -1, k = 1, ..., K, where N(K+1) = N(1).
C
C     NI      (input) INTEGER array, dimension (K)
C             The leading K elements of this array must contain the
C             dimensions of the factors of the matrix sequence T11_k.
C             N(k) >= NI(k) + NC >= 0.
C
C     S       (input) INTEGER array, dimension (K)
C             The leading K elements of this array must contain the
C             signatures (exponents) of the factors in the K-periodic
C             matrix sequence. Each entry in S must be either 1 or -1;
C             the value S(k) = -1 corresponds to using the inverse of
C             the factor T_k.
C
C     T       (input/output) DOUBLE PRECISION array, dimension (*)
C             On entry, this array must contain at position IXT(k) the
C             matrix T_k, which is at least N(k+1)-by-N(k), if S(k) = 1,
C             or at least N(k)-by-N(k+1), if S(k) = -1, in periodic
C             Schur form.
C             On exit, the matrices T_k are overwritten by the reordered
C             periodic Schur form.
C
C     LDT     INTEGER array, dimension (K)
C             The leading dimensions of the matrices T_k in the one-
C             dimensional array T.
C             LDT(k) >= max(1,N(k+1)),  if S(k) =  1,
C             LDT(k) >= max(1,N(k)),    if S(k) = -1.
C
C     IXT     INTEGER array, dimension (K)
C             Start indices of the matrices T_k in the one-dimensional
C             array T.
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (*)
C             On entry, this array must contain at position IXQ(k) a
C             matrix Q_k of size at least N(k)-by-N(k), provided that
C             COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) > 0.
C             On exit, if COMPQ = 'U', or COMPQ = 'W' and WHICHQ(k) > 0,
C             Q_k is post-multiplied with the orthogonal matrix that
C             performed the reordering.
C             This array is not referenced if COMPQ = 'N'.
C
C     LDQ     INTEGER array, dimension (K)
C             The leading dimensions of the matrices Q_k in the one-
C             dimensional array Q.
C             LDQ(k) >= max(1,N(k)), if COMPQ = 'U', or COMPQ = 'W' and
C                                                       WHICHQ(k) > 0;
C             This array is not referenced if COMPQ = 'N'.
C
C     IXQ     INTEGER array, dimension (K)
C             Start indices of the matrices Q_k in the one-dimensional
C             array Q.
C             This array is not referenced if COMPQ = 'N'.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION array, dimension (3)
C             This array contains tolerance parameters. The weak and
C             strong stability tests use a threshold computed by the
C             formula  MAX( c*EPS*NRM, SMLNUM ),  where c is a constant,
C             NRM is the Frobenius norm of the current matrix formed by
C             concatenating K pairs of adjacent diagonal blocks of sizes
C             1 and/or 2 in the T22_k submatrices from (2), which are
C             swapped, and EPS and SMLNUM are the machine precision and
C             safe minimum divided by EPS, respectively (see LAPACK
C             Library routine DLAMCH). The norm NRM is computed by this
C             routine; the other values are stored in the array TOL.
C             TOL(1), TOL(2), and TOL(3) contain c, EPS, and SMLNUM,
C             respectively. TOL(1) should normally be at least 10.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (4*K)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= 10*K + MN, if all blocks between IFST and ILST
C                                  have order 1;
C             LDWORK >= 25*K + MN, if there is at least a block of
C                                  order 2, but no adjacent blocks of
C                                  order 2 can appear between IFST and
C                                  ILST during reordering;
C             LDWORK >= MAX(42*K + MN, 80*K - 48), if at least a pair of
C                                  adjacent blocks of order 2 can appear
C                                  between IFST and ILST during
C                                  reordering;
C             where MN = MXN, if MXN > 10, and MN = 0, otherwise, with
C             MXN = MAX(N(k),k=1,...,K).
C
C             If LDWORK = -1  a workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -21, the LDWORK argument was too small;
C             = 1:  the reordering of T failed because some eigenvalues
C                   are too close to separate (the problem is very ill-
C                   conditioned); T may have been partially reordered.
C                   The returned value of ILST is the index where this
C                   was detected.
C
C     METHOD
C
C     An adaptation of the LAPACK Library routine DTGEXC is used.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically backward stable.
C
C     CONTRIBUTOR
C
C     R. Granat, Umea University, Sweden, Apr. 2008.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Mar. 2010, SLICOT Library version of the PEP routine PEP_DTGEXC.
C     V. Sima, July 2010.
C
C     KEYWORDS
C
C     Orthogonal transformation, periodic QZ algorithm, periodic
C     Sylvester-like equations, QZ algorithm.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          COMPQ
      LOGICAL            WS
      INTEGER            IFST, ILST, INFO, K, KSCHUR, LDWORK, NC
C     ..
C     .. Array Arguments ..
      INTEGER            IWORK( * ), IXQ( * ), IXT( * ), LDQ( * ),
     $                   LDT( * ), N( * ), NI( * ), S( * ), WHICHQ( * )
      DOUBLE PRECISION   DWORK( * ), Q( * ), T( * ), TOL( * )
C     ..
C     .. Local Scalars ..
      INTEGER            HERE, I, IP1, IT, MINWRK, NBF, NBL, NBNEXT
C     ..
C     .. External Subroutines ..
      EXTERNAL           MB03KB, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX, MOD
C     ..
C     .. Executable Statements ..
C
C     For efficiency reasons the parameters are not checked, except for
C     workspace.
C
      IF( NC.EQ.2 ) THEN
         NBF = 1
         NBL = 1
      ELSE IF( NC.EQ.3 ) THEN
         NBF = 1
         NBL = 2
      ELSE
         NBF = 2
         NBL = 2
      END IF
      CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, 1, NBF, NBL, N, NI,
     $             S, T, LDT, IXT, Q, LDQ, IXQ, TOL, IWORK, DWORK, -1,
     $             INFO )
      MINWRK = MAX( 1, INT( DWORK(1) ) )
      IF( LDWORK.NE.-1 .AND. LDWORK.LT.MINWRK )
     $   INFO = -21
C
C     Quick return if possible
C
      IF( LDWORK.EQ.-1 ) THEN
         DWORK(1) = DBLE( MINWRK )
         RETURN
      ELSE IF( INFO.LT.0 ) THEN
         CALL XERBLA( 'MB03KA', -INFO )
         RETURN
      END IF
C
C     Set I and IP1 to point to KSCHUR and KSCHUR+1 to simplify
C     indices below.
C
      I   = KSCHUR
      IP1 = MOD( I, K ) + 1
C
C     Determine the first row of the block in T22_kschur corresponding
C     to the first block in the product and find out if it is 1-by-1 or
C     2-by-2.
C
      IF( IFST.GT.1 ) THEN
         IF( S(I).EQ.1 ) THEN
            IT = IXT(I) + ( NI(I) + IFST - 2 )*LDT(I) + NI(IP1) + IFST
     $                  - 1
         ELSE
            IT = IXT(I) + ( NI(IP1) + IFST - 2 )*LDT(I) + NI(I) + IFST
     $                  - 1
         END IF
         IF( T( IT ).NE.ZERO )
     $      IFST = IFST - 1
      END IF
      NBF = 1
      IF( IFST.LT.NC ) THEN
         IF( S(I).EQ.1 ) THEN
            IT = IXT(I) + ( NI(I) + IFST - 1 )*LDT(I) + NI(IP1) + IFST
         ELSE
            IT = IXT(I) + ( NI(IP1) + IFST - 1 )*LDT(I) + NI(I) + IFST
         END IF
         IF( T( IT ).NE.ZERO )
     $      NBF = 2
      END IF
C
C     Determine the first row of the block in T_kschur corresponding
C     to the last block in the product and find out it is 1-by-1 or
C     2-by-2.
C
      IF( ILST.GT.1 ) THEN
         IF( S(I).EQ.1 ) THEN
            IT = IXT(I) + ( NI(I) + ILST - 2 )*LDT(I) + NI(IP1) + ILST
     $                  - 1
         ELSE
            IT = IXT(I) + ( NI(IP1) + ILST - 2 )*LDT(I) + NI(I) + ILST
     $                  - 1
         END IF
         IF( T( IT ).NE.ZERO )
     $      ILST = ILST - 1
      END IF
      NBL = 1
      IF( ILST.LT.NC ) THEN
         IF( S(I).EQ.1 ) THEN
            IT = IXT(I) + ( NI(I) + ILST - 1 )*LDT(I) + NI(IP1) + ILST
         ELSE
            IT = IXT(I) + ( NI(IP1) + ILST - 1 )*LDT(I) + NI(I) + ILST
         END IF
         IF( T( IT ).NE.ZERO )
     $      NBL = 2
      END IF
C
C     If the specified and last block in the product were the same,
C     return.
C
      IF( IFST.EQ.ILST )
     $   RETURN
C
C     If the specified block lies above the last block on the diagonal
C     of the product and the blocks have unequal sizes, update ILST.
C
      IF( IFST.LT.ILST ) THEN
C
C        Update ILST.
C
         IF( NBF.EQ.2 .AND. NBL.EQ.1 )
     $      ILST = ILST - 1
         IF( NBF.EQ.1 .AND. NBL.EQ.2 )
     $      ILST = ILST + 1
C
         HERE = IFST
C
   10    CONTINUE
C
C        Swap a block with next one below.
C
         IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
C
C           Current next block is either 1-by-1 or 2-by-2.
C
            NBNEXT = 1
            IF( HERE+NBF+1.LE.NC ) THEN
               IF( S(I).EQ.1 ) THEN
                  IT = IXT(I) + ( NI(I) + HERE + NBF - 1 )*LDT(I) +
     $                          NI(IP1) + HERE + NBF
               ELSE
                  IT = IXT(I) + ( NI(IP1) + HERE + NBF - 1 )*LDT(I) +
     $                              NI(I) + HERE + NBF
               END IF
               IF( T( IT ).NE.ZERO )
     $            NBNEXT = 2
            END IF
            CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE, NBF,
     $                   NBNEXT, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ,
     $                   TOL, IWORK, DWORK, LDWORK, INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               RETURN
            END IF
            HERE = HERE + NBNEXT
C
C           Test if a 2-by-2 block breaks into two 1-by-1 blocks.
C
            IF( NBF.EQ.2 ) THEN
               IF( S(I).EQ.1 ) THEN
                  IT = IXT(I) + ( NI(I) + HERE - 1 )*LDT(I) + NI(IP1)
     $                        + HERE
               ELSE
                  IT = IXT(I) + ( NI(IP1) + HERE - 1 )*LDT(I) + NI(I)
     $                        + HERE
               END IF
               IF( T( IT ).EQ.ZERO )
     $            NBF = 3
            END IF
         ELSE
C
C           Current next block consists of two 1-by-1 blocks each of
C           which must be swapped individually.
C
            NBNEXT = 1
            IF( HERE+3.LE.NC ) THEN
               IF( S(I).EQ.1 ) THEN
                  IT = IXT(I) + ( NI(I) + HERE + 1 )*LDT(I) + NI(IP1) +
     $                                    HERE + 2
               ELSE
                  IT = IXT(I) + ( NI(IP1) + HERE + 1 )*LDT(I) + NI(I) +
     $                                      HERE + 2
               END IF
               IF( T( IT ).NE.ZERO )
     $            NBNEXT = 2
            END IF
            CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE+1, 1,
     $                   NBNEXT, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ,
     $                   TOL, IWORK, DWORK, LDWORK, INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               RETURN
            END IF
            IF( NBNEXT.EQ.1 ) THEN
C
C              Swap two 1-by-1 blocks.
C
               CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE, 1,
     $                      NBNEXT, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ,
     $                      TOL, IWORK, DWORK, LDWORK, INFO )
               IF( INFO.NE.0 ) THEN
                  ILST = HERE
                  RETURN
               END IF
               HERE = HERE + 1
            ELSE
C
C              Recompute NBNEXT in case 2-by-2 split.
C
               IF( S(I).EQ.1 ) THEN
                  IT = IXT(I) + ( NI(I) + HERE )*LDT(I) + NI(IP1) + HERE
     $                        + 1
               ELSE
                  IT = IXT(I) + ( NI(IP1) + HERE )*LDT(I) + NI(I) + HERE
     $                                    + 1
               END IF
               IF( T( IT ).EQ.ZERO )
     $            NBNEXT = 1
               IF( NBNEXT.EQ.2 ) THEN
C
C                 The 2-by-2 block did not split.
C
                  CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE,
     $                         1, NBNEXT, N, NI, S, T, LDT, IXT, Q, LDQ,
     $                         IXQ, TOL, IWORK, DWORK, LDWORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE
                     RETURN
                  END IF
                  HERE = HERE + 2
               ELSE
C
C                 The 2-by-2 block did split.
C
                  CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE,
     $                         1, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ,
     $                         TOL, IWORK, DWORK, LDWORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE
                     RETURN
                  END IF
                  CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE+1,
     $                         1, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ,
     $                         TOL, IWORK, DWORK, LDWORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE + 1
                     RETURN
                  END IF
                  HERE = HERE + 2
               END IF
            END IF
         END IF
         IF( HERE.LT.ILST )
     $      GO TO 10
C
      ELSE
C
         HERE = IFST
   20    CONTINUE
C
C        Swap a block with next one above.
C
         IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
C
C           Current block is either 1-by-1 or 2-by-2.
C
            NBNEXT = 1
            IF( HERE.GE.3 ) THEN
               IF( S(I).EQ.1 ) THEN
                  IT = IXT(I) + ( NI(I) + HERE - 3 )*LDT(I) + NI(IP1)
     $                                  + HERE - 2
               ELSE
                  IT = IXT(I) + ( NI(IP1) + HERE - 3 )*LDT(I) + NI(I)
     $                                    + HERE - 2
               END IF
               IF( T( IT ).NE.ZERO )
     $            NBNEXT = 2
            END IF
            CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE-NBNEXT,
     $                   NBNEXT, NBF, N, NI, S, T, LDT, IXT, Q, LDQ,
     $                   IXQ, TOL, IWORK, DWORK, LDWORK, INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               RETURN
            END IF
            HERE = HERE - NBNEXT
C
C           Test if a 2-by-2 block breaks into two 1-by-1 blocks.
C
            IF( NBF.EQ.2 ) THEN
               IF( S(I).EQ.1 ) THEN
                  IT = IXT(I) + ( NI(I) + HERE - 1 )*LDT(I) + NI(IP1)
     $                                  + HERE
               ELSE
                  IT = IXT(I) + ( NI(IP1) + HERE - 1 )*LDT(I) + NI(I)
     $                                    + HERE
               END IF
               IF( T( IT ).EQ.ZERO )
     $            NBF = 3
            END IF
C
         ELSE
C
C           Current block consists of two 1-by-1 blocks each of which
C           must be swapped individually.
C
            NBNEXT = 1
            IF( HERE.GE.3 ) THEN
               IF( S(I).EQ.1 ) THEN
                  IT = IXT(I) + ( NI(I) + HERE - 3 )*LDT(I) + NI(IP1)
     $                                  + HERE - 2
               ELSE
                  IT = IXT(I) + ( NI(IP1) + HERE - 3 )*LDT(I) + NI(I)
     $                                    + HERE - 2
               END IF
               IF( T( IT ).NE.ZERO )
     $            NBNEXT = 2
            END IF
            CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE-NBNEXT,
     $                   NBNEXT, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ,
     $                   TOL, IWORK, DWORK, LDWORK, INFO )
            IF( INFO.NE.0 ) THEN
               ILST = HERE
               RETURN
            END IF
            IF( NBNEXT.EQ.1 ) THEN
C
C              Swap two 1-by-1 blocks.
C
               CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE,
     $                      NBNEXT, 1, N, NI, S, T, LDT, IXT, Q, LDQ,
     $                      IXQ, TOL, IWORK, DWORK, LDWORK, INFO )
               IF( INFO.NE.0 ) THEN
                  ILST = HERE
                  RETURN
               END IF
               HERE = HERE - 1
            ELSE
C
C              Recompute NBNEXT in case 2-by-2 split.
C
               IF( S(I).EQ.1 ) THEN
                  IT = IXT(I) + ( NI(I) + HERE - 2 )*LDT(I) + NI(IP1)
     $                                  + HERE - 1
               ELSE
                  IT = IXT(I) + ( NI(IP1) + HERE - 2 )*LDT(I) + NI(I)
     $                                    + HERE - 1
               END IF
               IF( T( IT ).EQ.ZERO )
     $            NBNEXT = 1
               IF( NBNEXT.EQ.2 ) THEN
C
C                 The 2-by-2 block did not split.
C
                  CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE-1,
     $                         2, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ,
     $                         TOL, IWORK, DWORK, LDWORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE
                     RETURN
                  END IF
                  HERE = HERE - 2
               ELSE

C                 The 2-by-2 block did split.
C
                  CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE,
     $                         1, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ,
     $                         TOL, IWORK, DWORK, LDWORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE
                     RETURN
                  END IF
                  CALL MB03KB( COMPQ, WHICHQ, WS, K, NC, KSCHUR, HERE-1,
     $                         1, 1, N, NI, S, T, LDT, IXT, Q, LDQ, IXQ,
     $                         TOL, IWORK, DWORK, LDWORK, INFO )
                  IF( INFO.NE.0 ) THEN
                     ILST = HERE - 1
                     RETURN
                  END IF
                  HERE = HERE - 2
               END IF
            END IF
         END IF
         IF( HERE.GT.ILST )
     $      GO TO 20
      END IF
      ILST = HERE
C
C     Store optimal workspace values and return.
C
      DWORK(1) = DBLE( MINWRK )
      RETURN
C
C *** Last line of MB03KA ***
      END


C
C***********************************************************************
C                                                                      *
C            NACHOS II - A Finite Element Computer Program             *
C                        for Incompressible Flow Problems              *
C                                                                      *
C     Copyright (c) 1986,2019   National Technology & Engineering      *
C                               Solutions of Sandia, LLC (NTESS)       *
C                                                                      *
C                            All rights reserved.                      *
C                                                                      *
C     This software is distributed under the BSD 3-Clause License.     *
C                                                                      *
C***********************************************************************
C
      SUBROUTINE COORD3 (XB,YB,XX,YY,S,T,INODE,ICONV)
C
C     ******************************************************************
C
C     SUBROUTINE TO LOCATE NORMALIZED COORDINATES S,T IN PARENT ELEMENT
C     SUBPARAMETRIC SIX-NODE TRIANGLE
C
C     ******************************************************************
C
      DIMENSION XX(*), YY(*)
      DIMENSION SS(3), TT(3)
C
      DATA SS/1.,0.,0./
      DATA TT/0.,1.,0./
      DATA TOL/.005/,IMAX/20/
C
C     STATEMENT FUNCTIONS FOR SHAPE FUNCTIONS AND DERIVATIVES
C
      FX(SP,TP)=XX(1)*SP+XX(2)*TP+XX(3)*(1.-SP-TP)
C
      FY(SP,TP)=YY(1)*SP+YY(2)*TP+YY(3)*(1.-SP-TP)
C
      DFXDS(SP,TP)=XX(1)-XX(3)
C
      DFYDS(SP,TP)=YY(1)-YY(3)
C
      DFXDT(SP,TP)=XX(2)-XX(3)
C
      DFYDT(SP,TP)=YY(2)-YY(3)
C
C     ******************************************************************
C
C     CHECK FOR COINCIDENT NODE
C
      IF (INODE.EQ.0) GO TO 10
C
      S=SS(INODE)
      T=TT(INODE)
      RETURN
C
C     USE NEWTON RAPHSON PROCEDURE TO COMPUTE S,T COORDINATES
C
   10 CONTINUE
      SG=0.
      TG=0.
      ICOUNT=0
   20 CONTINUE
C
C     BUILD JACOBIAN AND INVERT
C
      A11=DFXDS(SG,TG)
      A12=DFYDS(SG,TG)
      A21=DFXDT(SG,TG)
      A22=DFYDT(SG,TG)
      F1=FX(SG,TG)-XB
      F2=FY(SG,TG)-YB
      DETA=A11*A22-A12*A21
      SNEW=SG-(A22*F1-A21*F2)/DETA
      TNEW=TG-(-A12*F1+A11*F2)/DETA
C
C     CHECK CONVERGENCE
C
      ICOUNT=ICOUNT+1
      DS=ABS(SNEW-SG)
      DT=ABS(TNEW-TG)
      IF (DS.LT.TOL.AND.DT.LT.TOL) GO TO 30
      SG=SNEW
      TG=TNEW
      IF (ICOUNT.EQ.IMAX) GO TO 40
      GO TO 20
C
   30 CONTINUE
      S=SNEW
      T=TNEW
      RETURN
C
   40 CONTINUE
      ICONV=1
      RETURN
      END


	INCLUDE 'VICMAIN_FOR'
	SUBROUTINE MAIN44
C
	REAL XL1(2000),XL2(2000),XL3(2000),XS1(2000),XS2(2000),XS3(2000)
	REAL BUF(12)
	INTEGER*2 IMAGE(20000)
C								statement func
	XSECT(XL,XLT,XLB,XST,XSB) = ((XLB-XL)*XST + (XL-XLT)*XSB) /
     +				    (XLB-XLT)
C								open input
	CALL XVUNIT(INUNIT,'INP',1,ISTAT,' ')
	CALL XVOPEN(INUNIT,ISTAT,'OPEN_ACT','SA','IO_ACT','SA',' ')
C						    		get size field
	CALL XVSIZE(ISL,ISS,NL,NS,NTRI,NSIN)
	IEL = ISL + NL - 1
C								open output
	CALL XVUNIT(IOUTUNIT,'OUT',1,ISTAT,' ')
	CALL XVOPEN(IOUTUNIT,ISTAT,'OPEN_ACT','SA','IO_ACT','SA',
     +		    'U_NL',NL,'U_NS',NS,'OP','WRITE','O_FORMAT','HALF',
     +		    'U_FORMAT','HALF',' ')
C								get triangles
	DO I=1,NTRI
	    CALL XVREAD(INUNIT,BUF,ISTAT,' ')
	    XL1(I) = BUF(1)
	    XS1(I) = BUF(2)
	    XL2(I) = BUF(3)
	    XS2(I) = BUF(4)
	    XL3(I) = BUF(5)
	    XS3(I) = BUF(6)
	END DO
C							      build output image
	DO LINE=ISL,IEL
	    XLINE = LINE
	    CALL MVE(2,NS,0,IMAGE,0,1)			! zero out image line
	    DO I=1,NTRI
		IF (XL1(I) .GT. XLINE) GO TO 500
		IF (XL3(I) .GE. XLINE) THEN
		    A = XSECT(XLINE,XL1(I),XL3(I),XS1(I),XS3(I))
		    IF (XL2(I) .GT. XLINE .OR.
     +		       (XL2(I).EQ.XLINE .AND. XL3(I).EQ.XLINE) ) THEN
			B = XSECT(XLINE,XL1(I),XL2(I),XS1(I),XS2(I))
		    ELSE
			B = XSECT(XLINE,XL2(I),XL3(I),XS2(I),XS3(I))
		    END IF
C					A and B are the sample locations where
C					Line "LINE" intersects triangle "I"
C
		    IST = MIN(A,B,FLOAT(NS)) + 1.0
		    LAST = MAX(A,B,1.0)
		    DO J=IST,LAST
			IMAGE(J) = I
		    END DO
		END IF
	    END DO
  500	    CONTINUE
	    CALL XVWRIT(IOUTUNIT,IMAGE(ISS),ISTAT,' ')
	END DO
	RETURN
	END


	SUBROUTINE GAZMLM ( mproj, msppj, np, xl, yl, polat, polon,
     +			    rotat, azmsav, dlat, dlon, iret )
C************************************************************************
C* GAZMLM								*
C* 									*
C* This subroutine converts a point from linear intermediate		*
C* coordinates to latitude-longitude coordinates for azimuthal map	*
C* projections.								*
C* 									*
C* GAZMLM  ( MPROJ, MSPPJ, NP, XL, YL, POLAT, POLON, ROTAT, AZMSAV,	*
C*           DLAT,  DLON,  IRET )					*
C*									*
C* Input parameters:							*
C*	MPROJ		INTEGER		Map class			*
C*	MSPPJ		INTEGER		Map projection			*
C*	NP		INTEGER		Number of points		*
C*	XL (NP)		REAL		X linear coordinates		*
C*	YL (NP)		REAL		Y linear coordinates		*
C*	POLAT		REAL		Pole latitude			*
C*	POLON		REAL		Central longitude		*
C*	ROTAT		REAL		Rotation (not used)		*
C*	AZMSAV		REAL		Special azimuthal angle (unused)*
C* 									*
C* Output parameters:							*
C* 	DLAT (NP)	REAL		Latitudes			*
C* 	DLON (NP)	REAL		Longitudes			*
C* 	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* G. Chatters/RDS	 7/84	GEMPLT Version 3.0			*
C* M. desJardins/GSFC	 6/85	GEMPLT Version 3.1			*
C* B. Doty/RDS		 5/87	Corrected ATAN2 zero check		*
C* B. Doty/RDS		 7/87	Fixed Orthographic out-of-hemisphere	*
C* M. desJardins/GSFC	 1/88	Fixed error checking			*
C* M. desJardins/GSFC	 6/88	Cleaned up				*
C* K. Brill/NMC 	 4/91   Chngd .and. to .or. in chk for ATAN2	*
C* A. Taylor/ARL        12/93   Enabled Oblique Azimuthal Projections   *
C* K. Brill/NMC          1/94   Cleanup                                 *
C* K. Brill/EMC		 3/96	Remove Taylor code; general rotated proj*
C************************************************************************
	INCLUDE		'ERROR.PRM'
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		xl (*), yl (*), dlat (*), dlon (*)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = NORMAL
C
C*	Loop through all points.
C
	DO  i = 1, np
C
C*	  Check that input values are not missing.
C
	  IF  (( ERMISS ( xl (i) ) ) .or. ( ERMISS ( yl (i) ) ))  THEN
	    dlat (i) = RMISSD
	    dlon (i) = RMISSD
	  ELSE
	    gamp = RMISSD
	    a    = RMISSD
	    rlat = RMISSD
	    rlon = RMISSD
C
C*	    Compute polar coordinate componenets.
C
            IF ( ( xl(i) .ne. 0.0 ) .or. ( yl(i) .ne. 0.0 ) ) THEN
	        gamp = ATAN2 ( yl (i), xl (i) )
            ELSE
                gamp = 0.0
            ENDIF
	    r  =  SQRT  ( xl (i) ** 2 + yl (i) ** 2 )
C
C*	    Select range computation based on projection type.
C
C*	    Stereographic projection.
C
	    IF  ( mproj .eq. MPASTR ) THEN
		a = 2.0 * ATAN ( r )
C
C*	      Azimuthal equidistant projection.
C
	      ELSE IF ( ( mproj .eq. MPAEQU ) .and. ( r .le. PI ) ) THEN
		a = r
C
C*	      Orthographic projection.
C
	      ELSE IF  ( mproj .eq. MPAORT ) THEN
                IF ( r .le. 1.0 ) THEN
	            a = ASIN ( r )
                  ELSE
                    a = ASIN ( 1.0 )
                ENDIF
C
C*	      Lambert equal area projection.
C
	      ELSE IF  ( ( mproj .eq. MPALAM ) .and.
     +                  ( r .le. 2.0 ) ) THEN
		a = ACOS ( 1.0 - 0.5 * r**2 )
C
C*	      Gnomic projection.
C
	      ELSE IF ( mproj .eq. MPAGNO ) THEN
		a = ATAN ( r )
	    END IF
C
C*	    Do computations for special cases first.
C*	    General case is not implemented.
C
	    IF ((.not. ERMISS (gamp)) .and. (.not. ERMISS (a)))  THEN
C
	      IF  ( msppj .eq. MSANOR )  THEN
		rlon = gamp
		rlat = HALFPI - a
C*
	       ELSE IF ( msppj .eq. MSASOU ) THEN
		rlon = - gamp
		rlat = a - HALFPI
	      END IF
	    END IF
C
C*	    Convert to degrees.
C
	    IF ((.not. ERMISS (rlon)) .and. (.not. ERMISS (rlat))) THEN
		dlat (i) = rlat * RTD
		dlon (i) = ( rlon + polon ) * RTD
	      ELSE
		dlat (i) = RMISSD
		dlon (i) = RMISSD
	    END IF
	  END IF
	END DO
C*
	RETURN
	END


SUBROUTINE clawpack5_qinit(meqn,mbc,mx,my, &
     xlower,ylower,dx,dy,q,maux,aux)
  IMPLICIT NONE

  INTEGER meqn, mbc, mx, my, maux,this_block_idx
  DOUBLE PRECISION xlower, ylower, dx, dy
  DOUBLE PRECISION q(meqn,1-mbc:mx+mbc, 1-mbc:my+mbc)
  DOUBLE PRECISION aux(maux,1-mbc:mx+mbc, 1-mbc:my+mbc)

  INTEGER i,j
  INTEGER blockno, fc2d_clawpack5_get_block
  DOUBLE PRECISION x,y,z, xlow, ylow, w

  blockno = fc2d_clawpack5_get_block()

  DO j = 1-mbc,my+mbc
     DO i = 1-mbc,mx+mbc
        xlow = xlower + (i-1)*dx
        ylow = ylower + (j-1)*dy
        CALL cellave2(blockno,xlow,ylow,dx,dy,w)
        q(1,i,j) = w
     ENDDO
  ENDDO

  RETURN
END SUBROUTINE clawpack5_qinit


! Program to test DPROD intrinsic
program intrinsic_dprod
   implicit none
   real r, s, t
   double precision dp

   ! 6d60 doesn't fit in a 4-byte real
   r = 2e30
   s = 4e30
   dp = dprod (r, s)
   if ((dp .gt. 8.001d60) .or. (dp .lt. 7.999d60)) call abort
end program


*> \brief \b ZROTG
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZROTG(CA,CB,C,S)
*
*       .. Scalar Arguments ..
*       COMPLEX*16 CA,CB,S
*       DOUBLE PRECISION C
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>    ZROTG determines a double complex Givens rotation.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16_blas_level1
*
*  =====================================================================
      SUBROUTINE ZROTG(CA,CB,C,S)
*
*  -- Reference BLAS level1 routine (version 3.7.0) --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      COMPLEX*16 CA,CB,S
      DOUBLE PRECISION C
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      COMPLEX*16 ALPHA
      DOUBLE PRECISION NORM,SCALE
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC CDABS,DCMPLX,DCONJG,DSQRT
*     ..
      IF (CDABS(CA).EQ.0.0d0) THEN
         C = 0.0d0
         S = (1.0d0,0.0d0)
         CA = CB
      ELSE
         SCALE = CDABS(CA) + CDABS(CB)
         NORM = SCALE*DSQRT((CDABS(CA/DCMPLX(SCALE,0.0d0)))**2+
     $       (CDABS(CB/DCMPLX(SCALE,0.0d0)))**2)
         ALPHA = CA/CDABS(CA)
         C = CDABS(CA)/NORM
         S = ALPHA*DCONJG(CB)/NORM
         CA = ALPHA*NORM
      END IF
      RETURN
      END


! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     https://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.

module triangle

  use, intrinsic :: iso_c_binding, only: &
       c_double, c_int, c_bool, c_ptr, c_f_pointer
  use types, only: dp
  use curve, only: evaluate_curve_barycentric
  implicit none
  private specialize_workspace_sizes, specialize_triangle_one_round
  public &
       de_casteljau_one_round, evaluate_barycentric, &
       evaluate_barycentric_multi, evaluate_cartesian_multi, jacobian_both, &
       jacobian_det, specialize_triangle, subdivide_nodes, compute_edge_nodes, &
       shoelace_for_area, compute_area

contains

  subroutine de_casteljau_one_round( &
       num_nodes, dimension_, nodes, degree, &
       lambda1, lambda2, lambda3, new_nodes) &
       bind(c, name='BEZ_de_casteljau_one_round')

    ! NOTE: This is de Casteljau on a Bezier triangle / triangle.

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    integer(c_int), intent(in) :: degree
    real(c_double), intent(in) :: lambda1
    real(c_double), intent(in) :: lambda2
    real(c_double), intent(in) :: lambda3
    real(c_double), intent(out) :: &
         new_nodes(dimension_, num_nodes - degree - 1)
    ! Variables outside of signature.
    integer(c_int) :: index_
    integer(c_int) :: parent_i1, parent_i2, parent_i3
    integer(c_int) :: k, j

    index_ = 1
    parent_i1 = 1
    parent_i2 = 2
    parent_i3 = degree + 2
    ! NOTE: Throughout for index_ <--> (i, j, k) in the (degree - 1)
    !       triangle, we have parent_i1 = index_ + k <--> (i + 1, j, k),
    !       parent_i2 = index_ + k + 1 <--> (i, j + 1, k) and
    !       parent_i3 = index_ + degree + 1 <--> (i, j, k + 1).
    do k = 0, degree - 1
       do j = 0, degree - k - 1
          ! NOTE: i = (degree - 1) - j - k
          new_nodes(:, index_) = ( &
               lambda1 * nodes(:, parent_i1) + &
               lambda2 * nodes(:, parent_i2) + &
               lambda3 * nodes(:, parent_i3))
          ! Update all the indices.
          parent_i1 = parent_i1 + 1
          parent_i2 = parent_i2 + 1
          parent_i3 = parent_i3 + 1
          index_ = index_ + 1
       end do
       ! Update the indices that depend on k.
       parent_i1 = parent_i1 + 1
       parent_i2 = parent_i2 + 1
    end do

  end subroutine de_casteljau_one_round

  subroutine evaluate_barycentric( &
       num_nodes, dimension_, nodes, degree, &
       lambda1, lambda2, lambda3, point) &
       bind(c, name='BEZ_evaluate_barycentric')

    ! NOTE: This evaluation is on a Bezier triangle / triangle.
    ! NOTE: This assumes degree >= 1.

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    integer(c_int), intent(in) :: degree
    real(c_double), intent(in) :: lambda1
    real(c_double), intent(in) :: lambda2
    real(c_double), intent(in) :: lambda3
    real(c_double), intent(out) :: point(dimension_, 1)
    ! Variables outside of signature.
    real(c_double) :: param_vals(3, 1)

    param_vals(1, 1) = lambda1
    param_vals(2, 1) = lambda2
    param_vals(3, 1) = lambda3
    call evaluate_barycentric_multi( &
         num_nodes, dimension_, nodes, degree, 1, param_vals, point)

  end subroutine evaluate_barycentric

  subroutine evaluate_barycentric_multi( &
       num_nodes, dimension_, nodes, degree, num_vals, param_vals, evaluated) &
       bind(c, name='BEZ_evaluate_barycentric_multi')

    ! NOTE: This evaluation is on a Bezier triangle / triangle.
    ! NOTE: This assumes degree >= 1.

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    integer(c_int), intent(in) :: degree, num_vals
    real(c_double), intent(in) :: param_vals(num_vals, 3)
    real(c_double), intent(out) :: evaluated(dimension_, num_vals)
    ! Variables outside of signature.
    integer(c_int) :: k, binom_val, index_, new_index
    real(c_double) :: row_result(dimension_, num_vals)

    index_ = num_nodes
    forall (new_index = 1:num_vals)  ! Borrow new_index for this loop.
       evaluated(:, new_index) = nodes(:, index_)
    end forall

    if (degree == 0) then
       return
    end if

    binom_val = 1
    do k = degree - 1, 0, -1
       ! We want to go from (d C (k + 1)) to (d C k).
       binom_val = (binom_val * (k + 1)) / (degree - k)
       index_ = index_ - 1  ! Step to last element in row.
       !     k = d - 1, d - 2, ...
       ! d - k =     1,     2, ...
       ! We know row k has (d - k + 1) elements.
       new_index = index_ - degree + k  ! First element in row.

       ! lambda1 = param_vals(:, 1)
       ! lambda2 = param_vals(:, 2)
       call evaluate_curve_barycentric( &
            degree - k + 1, dimension_, nodes(:, new_index:index_), &
            num_vals, param_vals(:, 1), param_vals(:, 2), row_result)

       ! Update index for next iteration.
       index_ = new_index

       ! lambda3 = param_vals(:, 3)
       forall (new_index = 1:num_vals)  ! Borrow new_index for this loop.
          evaluated(:, new_index) = ( &
               param_vals(new_index, 3) * evaluated(:, new_index) + &
               binom_val * row_result(:, new_index))
       end forall
    end do

  end subroutine evaluate_barycentric_multi

  subroutine evaluate_cartesian_multi( &
       num_nodes, dimension_, nodes, degree, num_vals, param_vals, evaluated) &
       bind(c, name='BEZ_evaluate_cartesian_multi')

    ! NOTE: This evaluation is on a Bezier triangle / triangle.
    ! NOTE: This mostly copies evaluate_barycentric_multi but does not just
    !       call it directly. This is to avoid copying param_vals.

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    integer(c_int), intent(in) :: degree, num_vals
    real(c_double), intent(in) :: param_vals(num_vals, 2)
    real(c_double), intent(out) :: evaluated(dimension_, num_vals)
    ! Variables outside of signature.
    integer(c_int) :: k, binom_val, index_, new_index
    real(c_double) :: row_result(dimension_, num_vals)
    real(c_double) :: lambda1_vals(num_vals)

    index_ = num_nodes
    forall (new_index = 1:num_vals)  ! Borrow new_index for this loop.
       evaluated(:, new_index) = nodes(:, index_)
    end forall

    if (degree == 0) then
       return
    end if

    lambda1_vals = 1.0_dp - param_vals(:, 1) - param_vals(:, 2)

    binom_val = 1
    do k = degree - 1, 0, -1
       ! We want to go from (d C (k + 1)) to (d C k).
       binom_val = (binom_val * (k + 1)) / (degree - k)
       index_ = index_ - 1  ! Step to last element in row.
       !     k = d - 1, d - 2, ...
       ! d - k =     1,     2, ...
       ! We know row k has (d - k + 1) elements.
       new_index = index_ - degree + k  ! First element in row.

       ! lambda1 = param_vals(:, 1)
       ! lambda2 = param_vals(:, 1)
       call evaluate_curve_barycentric( &
            degree - k + 1, dimension_, nodes(:, new_index:index_), &
            num_vals, lambda1_vals, param_vals(:, 1), row_result)

       ! Update index for next iteration.
       index_ = new_index

       ! lambda3 = param_vals(:, 2)
       forall (new_index = 1:num_vals)  ! Borrow new_index for this loop.
          evaluated(:, new_index) = ( &
               param_vals(new_index, 2) * evaluated(:, new_index) + &
               binom_val * row_result(:, new_index))
       end forall
    end do

  end subroutine evaluate_cartesian_multi

  subroutine jacobian_both( &
       num_nodes, dimension_, nodes, degree, new_nodes) &
       bind(c, name='BEZ_jacobian_both')

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    integer(c_int), intent(in) :: degree
    real(c_double), intent(out) :: &
         new_nodes(2 * dimension_, num_nodes - degree - 1)
    ! Variables outside of signature.
    integer(c_int) :: index_, i, j, k, num_vals

    index_ = 1
    i = 1
    j = degree + 2
    do num_vals = degree, 1, -1
       do k = 0, num_vals - 1
          ! jacobian_s
          new_nodes(:dimension_, index_) = nodes(:, i + 1) - nodes(:, i)
          ! jacobian_t
          new_nodes(dimension_ + 1:, index_) = nodes(:, j) - nodes(:, i)
          ! Update the indices
          index_ = index_ + 1
          i = i + 1
          j = j + 1
       end do
       ! In between each row, the index_ gains an extra value.
       i = i + 1
    end do

    new_nodes = degree * new_nodes

  end subroutine jacobian_both

  subroutine jacobian_det( &
       num_nodes, nodes, degree, num_vals, param_vals, evaluated) &
       bind(c, name='BEZ_jacobian_det')

    integer(c_int), intent(in) :: num_nodes
    real(c_double), intent(in) :: nodes(2, num_nodes)
    integer(c_int), intent(in) :: degree, num_vals
    real(c_double), intent(in) :: param_vals(num_vals, 2)
    real(c_double), intent(out) :: evaluated(num_vals)
    ! Variables outside of signature.
    real(c_double) :: jac_nodes(4, num_nodes - degree - 1)
    real(c_double) :: Bs_Bt_vals(4, num_vals)
    real(c_double) :: determinant

    call jacobian_both( &
         num_nodes, 2, nodes, degree, jac_nodes)
    if (degree == 1) then
       determinant = ( &
            jac_nodes(1, 1) * jac_nodes(4, 1) - &
            jac_nodes(2, 1) * jac_nodes(3, 1))
       evaluated = determinant
    else
       call evaluate_cartesian_multi( &
            num_nodes - degree - 1, 4, jac_nodes, degree - 1, &
            num_vals, param_vals, Bs_Bt_vals)
       evaluated = ( &
            Bs_Bt_vals(1, :) * Bs_Bt_vals(4, :) - &
            Bs_Bt_vals(2, :) * Bs_Bt_vals(3, :))
    end if

  end subroutine jacobian_det

  subroutine specialize_workspace_sizes(degree, size_odd, size_even)

    ! NOTE: This is a helper for ``specialize_triangle()``.

    integer(c_int), intent(in) :: degree
    integer(c_int), intent(out) :: size_odd, size_even

    if (mod(degree, 2) == 1) then
       size_odd = ((degree + 1) * (degree + 3)**2 * (degree + 5)) / 64
       size_even = size_odd
    else if (mod(degree, 4) == 0) then
       size_odd = (degree * (degree + 2) * (degree + 4) * (degree + 6)) / 64
       size_even = (((degree + 2) * (degree + 4)) / 8)**2
    else
       size_odd = (((degree + 2) * (degree + 4)) / 8)**2
       size_even = (degree * (degree + 2) * (degree + 4) * (degree + 6)) / 64
    end if

  end subroutine specialize_workspace_sizes

  subroutine specialize_triangle_one_round( &
       dimension_, num_read, read_nodes, num_write, write_nodes, &
       size_read, size_write, step, local_degree, &
       weights_a, weights_b, weights_c)

    ! INVARIANT: `step + local_degree == (total) degree + 1`
    ! INVARIANT: `size_write == size_read - local_degree - 1`

    integer(c_int), intent(in) :: dimension_
    integer(c_int), intent(in) :: num_read
    real(c_double), intent(in) :: read_nodes(dimension_, num_read)
    integer(c_int), intent(in) :: num_write
    real(c_double), intent(inout) :: write_nodes(dimension_, num_write)
    integer(c_int), intent(in) :: size_read, size_write
    integer(c_int), intent(in) :: step, local_degree
    real(c_double), intent(in) :: weights_a(3), weights_b(3), weights_c(3)
    ! Variables outside of signature.
    integer(c_int) :: write_index, new_write, read_index, new_read, i

    ! First: (step, 0, 0)
    call de_casteljau_one_round( &
         size_read, dimension_, read_nodes(:, 1:size_read), &
         local_degree, weights_a(1), weights_a(2), weights_a(3), &
         write_nodes(:, 1:size_write))

    ! Second: (i, j, 0) for j > 0, i + j = step
    write_index = size_write + 1
    read_index = 1
    do i = 1, step
       new_write = write_index + size_write - 1
       new_read = read_index + size_read - 1
       call de_casteljau_one_round( &
            size_read, dimension_, read_nodes(:, read_index:new_read), &
            local_degree, weights_b(1), weights_b(2), weights_b(3), &
            write_nodes(:, write_index:new_write))
       ! Update the indices.
       write_index = new_write + 1
       read_index = new_read + 1
    end do

    ! Third:  (i, j, k) for k > 0, i + j + k = step
    read_index = 1
    do i = 1, ((step + 1) * step) / 2
       new_write = write_index + size_write - 1
       new_read = read_index + size_read - 1
       call de_casteljau_one_round( &
            size_read, dimension_, read_nodes(:, read_index:new_read), &
            local_degree, weights_c(1), weights_c(2), weights_c(3), &
            write_nodes(:, write_index:new_write))
       ! Update the indices.
       write_index = new_write + 1
       read_index = new_read + 1
    end do

  end subroutine specialize_triangle_one_round

  subroutine specialize_triangle( &
       num_nodes, dimension_, nodes, degree, &
       weights_a, weights_b, weights_c, specialized) &
       bind(c, name='BEZ_specialize_triangle')

    ! This re-parameterizes by "specializing" to a subregion of the unit
    ! triangle. This happens in waves by applying one round of de Casteljau
    ! with the given sets of barycentric weights. For example, in the degree
    ! 1 case, we transform
    !     [n0]          [dC(n0(1:3), a)]
    !     [  ] --> n1 = [dC(n0(1:3), b)]
    !     [  ]          [dC(n0(1:3), c)]
    ! where `n` on the LHS is 3xDIM and each of the transformed sets of
    ! nodes are 1xDIM (since de Casteljau drops the degree by 1). (NOTE:
    ! here I'm using `dC` as a shorthand for "de Casteljau" and `a` as a
    ! shorthand `weights_a`.) In the degree 2 case:
    !     [n0]          [dC(n0(1:6), a)]          [dC(n1(1:3), a)]
    !     [  ]          [              ]          [dC(n1(1:3), b)]
    !     [  ]          [              ] --> n2 = [dC(n1(4:6), b)]
    !     [  ] --> n1 = [dC(n0(1:6), b)]          [dC(n1(1:3), c)]
    !     [  ]          [              ]          [dC(n1(4:6), c)]
    !     [  ]          [              ]          [dC(n1(7:9), c)]
    !                   [dC(n0(1:6), c)]
    !                   [              ]
    !                   [              ]
    ! In the degree 3 case:
    !     [n0]          [dC(n0(1:10), a)]          [dC(n1( 1:6 ), a)]
    !     [  ]          [               ]          [                ]
    !     [  ]          [               ]          [                ]
    !     [  ]          [               ]          [dC(n1( 1:6 ), b)]
    !     [  ]          [               ]          [                ]
    !     [  ] --> n1 = [               ]          [                ]
    !     [  ]          [dC(n0(1:10), b)]          [dC(n1( 7:12), b)]
    !     [  ]          [               ]          [                ]
    !     [  ]          [               ]          [                ]
    !     [  ]          [               ] --> n2 = [dC(n1( 1:6 ), c)]
    !                   [               ]          [                ]
    !                   [               ]          [                ]
    !                   [dC(n0(1:10), c)]          [dC(n1( 7:12), c)]
    !                   [               ]          [                ]
    !                   [               ]          [                ]
    !                   [               ]          [dC(n1(13:18), c)]
    !                   [               ]          [                ]
    !                   [               ]          [                ]
    ! ... CONTINUING TO DEGREE 3 ...
    !                 [dC(n2( 1:3 ), a)]
    !                 [dC(n2( 1:3 ), b)]
    !                 [dC(n2( 4:6 ), b)]
    !                 [dC(n2( 7:9 ), b)]
    !                 [dC(n2( 1:3 ), c)]
    !     n2 --> n3 = [dC(n2( 4:6 ), c)]
    !                 [dC(n2( 7:9 ), c)]
    !                 [dC(n2(10:12), c)]
    !                 [dC(n2(13:15), c)]
    !                 [dC(n2(16:18), c)]
    ! For **all** cases, we are tracking applications of weights at
    ! each step:
    !     STEP 1: {a}, {b}, {c}
    !     STEP 2: {aa}, {ab}, {bb}, {ac}, {bc}, {cc}
    !     STEP 3: {aaa}, {aab}, {abb}, {bbb}, {aac}, ...
    ! and each of these quantities can be computed using the ones computed
    ! at the previous step. So in STEP 2, we compute {aa} by applying
    ! the `a` weights to {a}, we compute {ab} and {bb} by applying the
    ! `b` weights to {a} and {b} and we compute {ac}, {bc}, {cc} by
    ! applying the `c` weights to the whole set.
    !
    ! For a "general" step, we can treat the triple (#a, #b, #c) just like
    ! we treat an index triple (i, j, k), which we know has linear index
    ! (1-based) `1 + j + (k/2) (2(i + j) + k + 3)`. This is very useful because
    ! we can find the **previous** quantity by using this index. For example,
    ! to compute {aabccc} by applying `c` to {aabcc}, we know the index
    ! of the {aabcc} is 13 and the index of {aabccc} is 20. In fact, one can
    ! show that when dropping from (i, j, k) to (i, j, k - 1) the index will
    ! always drop by `(i + j + k) + 1 = step + 1`. Unfortunately, some values
    ! have no `c` weights at all, i.e. `k = 0`. For these special cases we
    ! also use the formula to show `(step, 0, 0) --> (step - 1, 0, 0)` has
    ! no change in index (both are the first index). From `(i, j, 0)` to
    ! `(i, j - 1, 0)` drops the index by `1`.
    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    integer(c_int), intent(in) :: degree
    real(c_double), intent(in) :: weights_a(3), weights_b(3), weights_c(3)
    real(c_double), intent(out) :: specialized(dimension_, num_nodes)
    ! Variables outside of signature.
    integer(c_int) :: num_curves, size, size_odd, size_even
    real(c_double), allocatable :: workspace_odd(:, :), workspace_even(:, :)
    integer(c_int) :: delta_nc, delta_size, size_new, step
    logical(c_bool) :: is_even

    num_curves = 1
    size = ((degree + 1) * (degree + 2)) / 2
    call specialize_workspace_sizes(degree, size_odd, size_even)
    allocate(workspace_odd(dimension_, size_odd))
    allocate(workspace_even(dimension_, size_even))

    ! `num_curves` and `delta_size` are triangular numbers going in
    ! the opposite direction. `num_curves` will go from 1, 3, 6, 10, ...
    ! and `delta_size` will go (d + 2 C 2), (d + 1 C 2), ...
    ! Since the delta between consecutive terms grows linearly, we track
    ! them as well to avoid multiplications.
    delta_nc = 2
    delta_size = -degree - 1
    is_even = .FALSE.  ! At `step == 1`.

    do step = 1, degree
       num_curves = num_curves + delta_nc
       size_new = size + delta_size
       if (step == 1) then
          ! Read from `nodes`, write to `workspace_odd`.
          call specialize_triangle_one_round( &
               dimension_, num_nodes, nodes, size_odd, workspace_odd, &
               size, size_new, step, degree + 1 - step, &
               weights_a, weights_b, weights_c)
       else if (is_even) then
          ! Read from `workspace_odd`, write to `workspace_even`.
          call specialize_triangle_one_round( &
               dimension_, size_odd, workspace_odd, &
               size_even, workspace_even, &
               size, size_new, step, degree + 1 - step, &
               weights_a, weights_b, weights_c)
       else
          ! Read from `workspace_even`, write to `workspace_odd`.
          call specialize_triangle_one_round( &
               dimension_, size_even, workspace_even, &
               size_odd, workspace_odd, &
               size, size_new, step, degree + 1 - step, &
               weights_a, weights_b, weights_c)
       end if

       ! Update our index values.
       size = size_new
       delta_nc = delta_nc + 1
       delta_size = delta_size + 1
       is_even = .NOT. is_even  ! Switch parity.
    end do

    ! Read from the last workspace that was written to.
    if (is_even) then
       specialized = workspace_odd(:, 1:num_nodes)
    else
       specialized = workspace_even(:, 1:num_nodes)
    end if

  end subroutine specialize_triangle

  subroutine subdivide_nodes( &
       num_nodes, dimension_, nodes, degree, &
       nodes_a, nodes_b, nodes_c, nodes_d) &
       bind(c, name='BEZ_subdivide_nodes_triangle')

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    integer(c_int), intent(in) :: degree
    real(c_double), intent(out) :: nodes_a(dimension_, num_nodes)
    real(c_double), intent(out) :: nodes_b(dimension_, num_nodes)
    real(c_double), intent(out) :: nodes_c(dimension_, num_nodes)
    real(c_double), intent(out) :: nodes_d(dimension_, num_nodes)

    if (degree == 1) then
       nodes_a(:, 1) = nodes(:, 1)
       nodes_a(:, 2) = 0.5_dp * (nodes(:, 1) + nodes(:, 2))
       nodes_a(:, 3) = 0.5_dp * (nodes(:, 1) + nodes(:, 3))
       nodes_b(:, 1) = 0.5_dp * (nodes(:, 2) + nodes(:, 3))
       nodes_b(:, 2) = nodes_a(:, 3)
       nodes_b(:, 3) = nodes_a(:, 2)
       nodes_c(:, 1) = nodes_a(:, 2)
       nodes_c(:, 2) = nodes(:, 2)
       nodes_c(:, 3) = nodes_b(:, 1)
       nodes_d(:, 1) = nodes_a(:, 3)
       nodes_d(:, 2) = nodes_b(:, 1)
       nodes_d(:, 3) = nodes(:, 3)
    else if (degree == 2) then
       nodes_a(:, 1) = nodes(:, 1)
       nodes_a(:, 2) = 0.5_dp * (nodes(:, 1) + nodes(:, 2))
       nodes_a(:, 3) = 0.25_dp * (nodes(:, 1) + 2 * nodes(:, 2) + nodes(:, 3))
       nodes_a(:, 4) = 0.5_dp * (nodes(:, 1) + nodes(:, 4))
       nodes_a(:, 5) = 0.25_dp * ( &
            nodes(:, 1) + nodes(:, 2) + nodes(:, 4) + nodes(:, 5))
       nodes_a(:, 6) = 0.25_dp * (nodes(:, 1) + 2 * nodes(:, 4) + nodes(:, 6))
       nodes_b(:, 1) = 0.25_dp * (nodes(:, 3) + 2 * nodes(:, 5) + nodes(:, 6))
       nodes_b(:, 2) = 0.25_dp * ( &
            nodes(:, 2) + nodes(:, 4) + nodes(:, 5) + nodes(:, 6))
       nodes_b(:, 3) = nodes_a(:, 6)
       nodes_b(:, 4) = 0.25_dp * ( &
            nodes(:, 2) + nodes(:, 3) + nodes(:, 4) + nodes(:, 5))
       nodes_b(:, 5) = nodes_a(:, 5)
       nodes_b(:, 6) = nodes_a(:, 3)
       nodes_c(:, 1) = nodes_a(:, 3)
       nodes_c(:, 2) = 0.5_dp * (nodes(:, 2) + nodes(:, 3))
       nodes_c(:, 3) = nodes(:, 3)
       nodes_c(:, 4) = nodes_b(:, 4)
       nodes_c(:, 5) = 0.5_dp * (nodes(:, 3) + nodes(:, 5))
       nodes_c(:, 6) = nodes_b(:, 1)
       nodes_d(:, 1) = nodes_a(:, 6)
       nodes_d(:, 2) = nodes_b(:, 2)
       nodes_d(:, 3) = nodes_b(:, 1)
       nodes_d(:, 4) = 0.5_dp * (nodes(:, 4) + nodes(:, 6))
       nodes_d(:, 5) = 0.5_dp * (nodes(:, 5) + nodes(:, 6))
       nodes_d(:, 6) = nodes(:, 6)
    else if (degree == 3) then
       nodes_a(:, 1) = nodes(:, 1)
       nodes_a(:, 2) = 0.5_dp * (nodes(:, 1) + nodes(:, 2))
       nodes_a(:, 3) = 0.25_dp * (nodes(:, 1) + 2 * nodes(:, 2) + nodes(:, 3))
       nodes_a(:, 4) = 0.125_dp * ( &
            nodes(:, 1) + 3 * nodes(:, 2) + 3 * nodes(:, 3) + nodes(:, 4))
       nodes_a(:, 5) = 0.5_dp * (nodes(:, 1) + nodes(:, 5))
       nodes_a(:, 6) = 0.25_dp * ( &
            nodes(:, 1) + nodes(:, 2) + nodes(:, 5) + nodes(:, 6))
       nodes_a(:, 7) = 0.125_dp * ( &
            nodes(:, 1) + 2 * nodes(:, 2) + nodes(:, 3) + nodes(:, 5) + &
            2 * nodes(:, 6) + nodes(:, 7))
       nodes_a(:, 8) = 0.25_dp * (nodes(:, 1) + 2 * nodes(:, 5) + nodes(:, 8))
       nodes_a(:, 9) = 0.125_dp * ( &
            nodes(:, 1) + nodes(:, 2) + 2 * nodes(:, 5) + 2 * nodes(:, 6) + &
            nodes(:, 8) + nodes(:, 9))
       nodes_a(:, 10) = 0.125_dp * ( &
            nodes(:, 1) + 3 * nodes(:, 5) + 3 * nodes(:, 8) + nodes(:, 10))
       nodes_b(:, 1) = 0.125_dp * ( &
            nodes(:, 4) + 3 * nodes(:, 7) + 3 * nodes(:, 9) + nodes(:, 10))
       nodes_b(:, 2) = 0.125_dp * ( &
            nodes(:, 3) + 2 * nodes(:, 6) + nodes(:, 7) + nodes(:, 8) + &
            2 * nodes(:, 9) + nodes(:, 10))
       nodes_b(:, 3) = 0.125_dp * ( &
            nodes(:, 2) + nodes(:, 5) + 2 * nodes(:, 6) + 2 * nodes(:, 8) + &
            nodes(:, 9) + nodes(:, 10))
       nodes_b(:, 4) = nodes_a(:, 10)
       nodes_b(:, 5) = 0.125_dp * ( &
            nodes(:, 3) + nodes(:, 4) + 2 * nodes(:, 6) + 2 * nodes(:, 7) + &
            nodes(:, 8) + nodes(:, 9))
       nodes_b(:, 6) = 0.125_dp * ( &
            nodes(:, 2) + nodes(:, 3) + nodes(:, 5) + 2 * nodes(:, 6) + &
            nodes(:, 7) + nodes(:, 8) + nodes(:, 9))
       nodes_b(:, 7) = nodes_a(:, 9)
       nodes_b(:, 8) = 0.125_dp * ( &
            nodes(:, 2) + 2 * nodes(:, 3) + nodes(:, 4) + nodes(:, 5) + &
            2 * nodes(:, 6) + nodes(:, 7))
       nodes_b(:, 9) = nodes_a(:, 7)
       nodes_b(:, 10) = nodes_a(:, 4)
       nodes_c(:, 1) = nodes_a(:, 4)
       nodes_c(:, 2) = 0.25_dp * (nodes(:, 2) + 2 * nodes(:, 3) + nodes(:, 4))
       nodes_c(:, 3) = 0.5_dp * (nodes(:, 3) + nodes(:, 4))
       nodes_c(:, 4) = nodes(:, 4)
       nodes_c(:, 5) = nodes_b(:, 8)
       nodes_c(:, 6) = 0.25_dp * ( &
            nodes(:, 3) + nodes(:, 4) + nodes(:, 6) + nodes(:, 7))
       nodes_c(:, 7) = 0.5_dp * (nodes(:, 4) + nodes(:, 7))
       nodes_c(:, 8) = nodes_b(:, 5)
       nodes_c(:, 9) = 0.25_dp * (nodes(:, 4) + 2 * nodes(:, 7) + nodes(:, 9))
       nodes_c(:, 10) = nodes_b(:, 1)
       nodes_d(:, 1) = nodes_a(:, 10)
       nodes_d(:, 2) = nodes_b(:, 3)
       nodes_d(:, 3) = nodes_b(:, 2)
       nodes_d(:, 4) = nodes_b(:, 1)
       nodes_d(:, 5) = 0.25_dp * (nodes(:, 5) + 2 * nodes(:, 8) + nodes(:, 10))
       nodes_d(:, 6) = 0.25_dp * ( &
            nodes(:, 6) + nodes(:, 8) + nodes(:, 9) + nodes(:, 10))
       nodes_d(:, 7) = 0.25_dp * (nodes(:, 7) + 2 * nodes(:, 9) + nodes(:, 10))
       nodes_d(:, 8) = 0.5_dp * (nodes(:, 8) + nodes(:, 10))
       nodes_d(:, 9) = 0.5_dp * (nodes(:, 9) + nodes(:, 10))
       nodes_d(:, 10) = nodes(:, 10)
    else if (degree == 4) then
       nodes_a(:, 1) = nodes(:, 1)
       nodes_a(:, 2) = 0.5_dp * (nodes(:, 1) + nodes(:, 2))
       nodes_a(:, 3) = 0.25_dp * (nodes(:, 1) + 2 * nodes(:, 2) + nodes(:, 3))
       nodes_a(:, 4) = 0.125_dp * ( &
            nodes(:, 1) + 3 * nodes(:, 2) + 3 * nodes(:, 3) + nodes(:, 4))
       nodes_a(:, 5) = 0.0625_dp * ( &
            nodes(:, 1) + 4 * nodes(:, 2) + 6 * nodes(:, 3) + &
            4 * nodes(:, 4) + nodes(:, 5))
       nodes_a(:, 6) = 0.5_dp * (nodes(:, 1) + nodes(:, 6))
       nodes_a(:, 7) = 0.25_dp * ( &
            nodes(:, 1) + nodes(:, 2) + nodes(:, 6) + nodes(:, 7))
       nodes_a(:, 8) = 0.125_dp * ( &
            nodes(:, 1) + 2 * nodes(:, 2) + nodes(:, 3) + nodes(:, 6) + &
            2 * nodes(:, 7) + nodes(:, 8))
       nodes_a(:, 9) = 0.0625_dp * ( &
            nodes(:, 1) + 3 * nodes(:, 2) + 3 * nodes(:, 3) + nodes(:, 4) + &
            nodes(:, 6) + 3 * nodes(:, 7) + 3 * nodes(:, 8) + nodes(:, 9))
       nodes_a(:, 10) = 0.25_dp * ( &
            nodes(:, 1) + 2 * nodes(:, 6) + nodes(:, 10))
       nodes_a(:, 11) = 0.125_dp * ( &
            nodes(:, 1) + nodes(:, 2) + 2 * nodes(:, 6) + 2 * nodes(:, 7) + &
            nodes(:, 10) + nodes(:, 11))
       nodes_a(:, 12) = 0.0625_dp * ( &
            nodes(:, 1) + 2 * nodes(:, 2) + nodes(:, 3) + 2 * nodes(:, 6) + &
            4 * nodes(:, 7) + 2 * nodes(:, 8) + nodes(:, 10) + &
            2 * nodes(:, 11) + nodes(:, 12))
       nodes_a(:, 13) = 0.125_dp * ( &
            nodes(:, 1) + 3 * nodes(:, 6) + 3 * nodes(:, 10) + nodes(:, 13))
       nodes_a(:, 14) = 0.0625_dp * ( &
            nodes(:, 1) + nodes(:, 2) + 3 * nodes(:, 6) + 3 * nodes(:, 7) + &
            3 * nodes(:, 10) + 3 * nodes(:, 11) + nodes(:, 13) + nodes(:, 14))
       nodes_a(:, 15) = 0.0625_dp * ( &
            nodes(:, 1) + 4 * nodes(:, 6) + 6 * nodes(:, 10) + &
            4 * nodes(:, 13) + nodes(:, 15))
       nodes_b(:, 1) = 0.0625_dp * ( &
            nodes(:, 5) + 4 * nodes(:, 9) + 6 * nodes(:, 12) + &
            4 * nodes(:, 14) + nodes(:, 15))
       nodes_b(:, 2) = 0.0625_dp * ( &
            nodes(:, 4) + 3 * nodes(:, 8) + nodes(:, 9) + 3 * nodes(:, 11) + &
            3 * nodes(:, 12) + nodes(:, 13) + 3 * nodes(:, 14) + nodes(:, 15))
       nodes_b(:, 3) = 0.0625_dp * ( &
            nodes(:, 3) + 2 * nodes(:, 7) + 2 * nodes(:, 8) + nodes(:, 10) + &
            4 * nodes(:, 11) + nodes(:, 12) + 2 * nodes(:, 13) + &
            2 * nodes(:, 14) + nodes(:, 15))
       nodes_b(:, 4) = 0.0625_dp * ( &
            nodes(:, 2) + nodes(:, 6) + 3 * nodes(:, 7) + 3 * nodes(:, 10) + &
            3 * nodes(:, 11) + 3 * nodes(:, 13) + nodes(:, 14) + nodes(:, 15))
       nodes_b(:, 5) = nodes_a(:, 15)
       nodes_b(:, 6) = 0.0625_dp * ( &
            nodes(:, 4) + nodes(:, 5) + 3 * nodes(:, 8) + 3 * nodes(:, 9) + &
            3 * nodes(:, 11) + 3 * nodes(:, 12) + nodes(:, 13) + nodes(:, 14))
       nodes_b(:, 7) = 0.0625_dp * ( &
            nodes(:, 3) + nodes(:, 4) + 2 * nodes(:, 7) + 3 * nodes(:, 8) + &
            nodes(:, 9) + nodes(:, 10) + 3 * nodes(:, 11) + &
            2 * nodes(:, 12) + nodes(:, 13) + nodes(:, 14))
       nodes_b(:, 8) = 0.0625_dp * ( &
            nodes(:, 2) + nodes(:, 3) + nodes(:, 6) + 3 * nodes(:, 7) + &
            2 * nodes(:, 8) + 2 * nodes(:, 10) + 3 * nodes(:, 11) + &
            nodes(:, 12) + nodes(:, 13) + nodes(:, 14))
       nodes_b(:, 9) = nodes_a(:, 14)
       nodes_b(:, 10) = 0.0625_dp * ( &
            nodes(:, 3) + 2 * nodes(:, 4) + nodes(:, 5) + 2 * nodes(:, 7) + &
            4 * nodes(:, 8) + 2 * nodes(:, 9) + nodes(:, 10) + &
            2 * nodes(:, 11) + nodes(:, 12))
       nodes_b(:, 11) = 0.0625_dp * ( &
            nodes(:, 2) + 2 * nodes(:, 3) + nodes(:, 4) + nodes(:, 6) + &
            3 * nodes(:, 7) + 3 * nodes(:, 8) + nodes(:, 9) + nodes(:, 10) + &
            2 * nodes(:, 11) + nodes(:, 12))
       nodes_b(:, 12) = nodes_a(:, 12)
       nodes_b(:, 13) = 0.0625_dp * ( &
            nodes(:, 2) + 3 * nodes(:, 3) + 3 * nodes(:, 4) + nodes(:, 5) + &
            nodes(:, 6) + 3 * nodes(:, 7) + 3 * nodes(:, 8) + nodes(:, 9))
       nodes_b(:, 14) = nodes_a(:, 9)
       nodes_b(:, 15) = nodes_a(:, 5)
       nodes_c(:, 1) = nodes_a(:, 5)
       nodes_c(:, 2) = 0.125_dp * ( &
            nodes(:, 2) + 3 * nodes(:, 3) + 3 * nodes(:, 4) + nodes(:, 5))
       nodes_c(:, 3) = 0.25_dp * ( &
            nodes(:, 3) + 2 * nodes(:, 4) + nodes(:, 5))
       nodes_c(:, 4) = 0.5_dp * ( &
            nodes(:, 4) + nodes(:, 5))
       nodes_c(:, 5) = nodes(:, 5)
       nodes_c(:, 6) = nodes_b(:, 13)
       nodes_c(:, 7) = 0.125_dp * ( &
            nodes(:, 3) + 2 * nodes(:, 4) + nodes(:, 5) + nodes(:, 7) + &
            2 * nodes(:, 8) + nodes(:, 9))
       nodes_c(:, 8) = 0.25_dp * ( &
            nodes(:, 4) + nodes(:, 5) + nodes(:, 8) + nodes(:, 9))
       nodes_c(:, 9) = 0.5_dp * (nodes(:, 5) + nodes(:, 9))
       nodes_c(:, 10) = nodes_b(:, 10)
       nodes_c(:, 11) = 0.125_dp * ( &
            nodes(:, 4) + nodes(:, 5) + 2 * nodes(:, 8) + 2 * nodes(:, 9) + &
            nodes(:, 11) + nodes(:, 12))
       nodes_c(:, 12) = 0.25_dp * ( &
            nodes(:, 5) + 2 * nodes(:, 9) + nodes(:, 12))
       nodes_c(:, 13) = nodes_b(:, 6)
       nodes_c(:, 14) = 0.125_dp * ( &
            nodes(:, 5) + 3 * nodes(:, 9) + 3 * nodes(:, 12) + nodes(:, 14))
       nodes_c(:, 15) = nodes_b(:, 1)
       nodes_d(:, 1) = nodes_a(:, 15)
       nodes_d(:, 2) = nodes_b(:, 4)
       nodes_d(:, 3) = nodes_b(:, 3)
       nodes_d(:, 4) = nodes_b(:, 2)
       nodes_d(:, 5) = nodes_b(:, 1)
       nodes_d(:, 6) = 0.125_dp * ( &
            nodes(:, 6) + 3 * nodes(:, 10) + 3 * nodes(:, 13) + nodes(:, 15))
       nodes_d(:, 7) = 0.125_dp * ( &
            nodes(:, 7) + nodes(:, 10) + 2 * nodes(:, 11) + &
            2 * nodes(:, 13) + nodes(:, 14) + nodes(:, 15))
       nodes_d(:, 8) = 0.125_dp * ( &
            nodes(:, 8) + 2 * nodes(:, 11) + nodes(:, 12) + nodes(:, 13) + &
            2 * nodes(:, 14) + nodes(:, 15))
       nodes_d(:, 9) = 0.125_dp * ( &
            nodes(:, 9) + 3 * nodes(:, 12) + 3 * nodes(:, 14) + nodes(:, 15))
       nodes_d(:, 10) = 0.25_dp * ( &
            nodes(:, 10) + 2 * nodes(:, 13) + nodes(:, 15))
       nodes_d(:, 11) = 0.25_dp * ( &
            nodes(:, 11) + nodes(:, 13) + nodes(:, 14) + nodes(:, 15))
       nodes_d(:, 12) = 0.25_dp * ( &
            nodes(:, 12) + 2 * nodes(:, 14) + nodes(:, 15))
       nodes_d(:, 13) = 0.5_dp * (nodes(:, 13) + nodes(:, 15))
       nodes_d(:, 14) = 0.5_dp * (nodes(:, 14) + nodes(:, 15))
       nodes_d(:, 15) = nodes(:, 15)
    else
       call specialize_triangle( &
            num_nodes, dimension_, nodes, degree, &
            [1.0_dp, 0.0_dp, 0.0_dp], &
            [0.5_dp, 0.5_dp, 0.0_dp], &
            [0.5_dp, 0.0_dp, 0.5_dp], &
            nodes_a)
       call specialize_triangle( &
            num_nodes, dimension_, nodes, degree, &
            [0.0_dp, 0.5_dp, 0.5_dp], &
            [0.5_dp, 0.0_dp, 0.5_dp], &
            [0.5_dp, 0.5_dp, 0.0_dp], &
            nodes_b)
       call specialize_triangle( &
            num_nodes, dimension_, nodes, degree, &
            [0.5_dp, 0.5_dp, 0.0_dp], &
            [0.0_dp, 1.0_dp, 0.0_dp], &
            [0.0_dp, 0.5_dp, 0.5_dp], &
            nodes_c)
       call specialize_triangle( &
            num_nodes, dimension_, nodes, degree, &
            [0.5_dp, 0.0_dp, 0.5_dp], &
            [0.0_dp, 0.5_dp, 0.5_dp], &
            [0.0_dp, 0.0_dp, 1.0_dp], &
            nodes_d)
    end if

  end subroutine subdivide_nodes

  subroutine compute_edge_nodes( &
       num_nodes, dimension_, nodes, degree, nodes1, nodes2, nodes3) &
       bind(c, name='BEZ_compute_edge_nodes')

    integer(c_int), intent(in) :: num_nodes, dimension_
    real(c_double), intent(in) :: nodes(dimension_, num_nodes)
    integer(c_int), intent(in) :: degree
    real(c_double), intent(out) :: nodes1(dimension_, degree + 1)
    real(c_double), intent(out) :: nodes2(dimension_, degree + 1)
    real(c_double), intent(out) :: nodes3(dimension_, degree + 1)
    ! Variables outside of signature.
    integer(c_int) :: index1, index2, index3

    index2 = degree + 1
    index3 = num_nodes
    do index1 = 1, degree + 1
       nodes1(:, index1) = nodes(:, index1)
       nodes2(:, index1) = nodes(:, index2)
       nodes3(:, index1) = nodes(:, index3)
       ! Update the indices.
       index2 = index2 - index1 + degree + 1
       index3 = index3 - index1 - 1
    end do

  end subroutine compute_edge_nodes

  subroutine shoelace_for_area(num_nodes, nodes, shoelace, not_implemented)

    ! NOTE: This is a helper for ``compute_area()``.
    ! NOTE: This subroutine is not part of the C ABI for this module,
    !       but it is (for now) public, so that it can be tested.

    integer(c_int), intent(in) :: num_nodes
    real(c_double), intent(in) :: nodes(2, num_nodes)
    real(c_double), intent(out) :: shoelace
    logical(c_bool), intent(out) :: not_implemented

    not_implemented = .FALSE.
    if (num_nodes == 2) then
       shoelace = ( &
            nodes(1, 1) * nodes(2, 2) - nodes(2, 1) * nodes(1, 2))
       shoelace = shoelace / 2
    else if (num_nodes == 3) then
       shoelace = ( &
            2 * (nodes(1, 1) * nodes(2, 2) - nodes(2, 1) * nodes(1, 2)) + &
            (nodes(1, 1) * nodes(2, 3) - nodes(2, 1) * nodes(1, 3)) + &
            2 * (nodes(1, 2) * nodes(2, 3) - nodes(2, 2) * nodes(1, 3)))
       shoelace = shoelace / 6
    else if (num_nodes == 4) then
       shoelace = ( &
            6 * (nodes(1, 1) * nodes(2, 2) - nodes(2, 1) * nodes(1, 2)) + &
            3 * (nodes(1, 1) * nodes(2, 3) - nodes(2, 1) * nodes(1, 3)) + &
            (nodes(1, 1) * nodes(2, 4) - nodes(2, 1) * nodes(1, 4)) + &
            3 * (nodes(1, 2) * nodes(2, 3) - nodes(2, 2) * nodes(1, 3)) + &
            3 * (nodes(1, 2) * nodes(2, 4) - nodes(2, 2) * nodes(1, 4)) + &
            6 * (nodes(1, 3) * nodes(2, 4) - nodes(2, 3) * nodes(1, 4)))
       shoelace = shoelace / 20
    else if (num_nodes == 5) then
       shoelace = ( &
            20 * (nodes(1, 1) * nodes(2, 2) - nodes(2, 1) * nodes(1, 2)) + &
            10 * (nodes(1, 1) * nodes(2, 3) - nodes(2, 1) * nodes(1, 3)) + &
            4 * (nodes(1, 1) * nodes(2, 4) - nodes(2, 1) * nodes(1, 4)) + &
            (nodes(1, 1) * nodes(2, 5) - nodes(2, 1) * nodes(1, 5)) + &
            8 * (nodes(1, 2) * nodes(2, 3) - nodes(2, 2) * nodes(1, 3)) + &
            8 * (nodes(1, 2) * nodes(2, 4) - nodes(2, 2) * nodes(1, 4)) + &
            4 * (nodes(1, 2) * nodes(2, 5) - nodes(2, 2) * nodes(1, 5)) + &
            8 * (nodes(1, 3) * nodes(2, 4) - nodes(2, 3) * nodes(1, 4)) + &
            10 * (nodes(1, 3) * nodes(2, 5) - nodes(2, 3) * nodes(1, 5)) + &
            20 * (nodes(1, 4) * nodes(2, 5) - nodes(2, 4) * nodes(1, 5)))
       shoelace = shoelace / 70
    else
       shoelace = 0.0_dp
       not_implemented = .TRUE.
    end if

  end subroutine shoelace_for_area

  subroutine compute_area( &
       num_edges, sizes, nodes_pointers, area, not_implemented) &
       bind(c, name='BEZ_compute_area')

    integer(c_int), intent(in) :: num_edges
    integer(c_int), intent(in) :: sizes(num_edges)
    type(c_ptr), intent(in) :: nodes_pointers(num_edges)
    real(c_double), intent(out) :: area
    logical(c_bool), intent(out) :: not_implemented
    ! Variables outside of signature.
    integer(c_int) :: i
    real(c_double), pointer :: nodes(:, :)
    real(c_double) :: shoelace

    area = 0.0_dp
    do i = 1, num_edges
       call c_f_pointer(nodes_pointers(i), nodes, [2, sizes(i)])
       call shoelace_for_area(sizes(i), nodes, shoelace, not_implemented)
       if (not_implemented) then
          return
       else
          area = area + shoelace
       end if
    end do

  end subroutine compute_area

end module triangle


           program demo_aint
           use, intrinsic :: iso_fortran_env, only : real_kinds, &
           & real32, real64, real128
           implicit none
           real ::  x4
           real(kind=real64) :: x8
              x4 = 1.234E0_4
              x8 = 4.321_real64
              print *, aint(x4), dint(x8)
              x8 = aint(x4,kind=real64)
           end program demo_aint


program complex
  complex :: x
  x = cmplx(0.0,1.0)
  call func(x)

contains
  subroutine exit(status)
    integer, value :: status
  end subroutine exit

  subroutine func(x)
    complex, value :: x
    if (abs(imag(x) - 1.0) .ge. 0.1) then
       call exit(1)
    else
       call exit(0)
    endif
  end subroutine func
end program complex


c	Fiddle to get around the fact that mf and knuth are both written
c       for floating poing data only
c
c
c       bam 10/98
c

C
	INCLUDE 'VICMAIN_FOR'

	SUBROUTINE MAIN44
	IMPLICIT NONE

        INTEGER iUNIT, iSTAT, DEF
        INTEGER INCOLS(100),OUTCOLS(100),COLS(100)
        REAL*8 VALUE
	INTEGER	INCOL_COUNT, OUTCOL_COUNT
        INTEGER I,J
        INTEGER IXTRAN
        REAL*8  DMIN,DMAX,SUM
        INTEGER IMIN,IMAX
        INTEGER COUNT

        logical xvptst

        INTEGER IBIS
        INTEGER RECORDD
        INTEGER NR,NC
	INTEGER	ROW
	REAL*8 ROWBUF(100)
        REAL*8 TEMP(100)

C*********************************************************************

        CALL XVUNIT(IUNIT,'INP',1,ISTAT,' ')

        CALL IFMESSAGE('*** mfd version 2017-08-09 ***')
        CALL XVEACTION('SA',' ')

C       GET THE INPUT/OUTPUT COLUMN/S

	CALL XVPARM ('INCOLS', INCOLS, INCOL_COUNT, DEF, 100)
	CALL XVPARM ('OUTCOLS',OUTCOLS,OUTCOL_COUNT, DEF, 100)
	CALL XVPARMD('VALUE',VALUE,COUNT,DEF,1)

C	OPEN IBIS INTERFACE FILE

	CALL IBIS_FILE_OPEN(IUNIT,IBIS,'UPDATE',0,0,' ',' ',ISTAT)
        IF (ISTAT.NE.1) CALL IBIS_SIGNAL_U(IUNIT,ISTAT,1)

C       get # of rows and columns

        CALL IBIS_FILE_GET(IBIS,'NC',NC,1,1)
        CALL IBIS_FILE_GET(IBIS,'NR',NR,1,1)

       IF(XVPTST('ADD'))  IXTRAN = 1
       IF(XVPTST('SUB'))  IXTRAN = 2
       IF(XVPTST('MULT')) IXTRAN = 3
       IF(XVPTST('DIV'))  IXTRAN = 4
       IF(XVPTST('INT'))  IXTRAN = 5
       IF(XVPTST('ABS'))  IXTRAN = 6
       IF(XVPTST('SQR'))  IXTRAN = 7
       IF(XVPTST('MIN'))  IXTRAN = 8
       IF(XVPTST('MAX'))  IXTRAN = 9
       IF(XVPTST('SET'))  IXTRAN = 10
       IF(XVPTST('INDEX'))IXTRAN = 11
       IF(XVPTST('EQ'))   IXTRAN = 12
       IF(XVPTST('NE'))   IXTRAN = 13
       IF(XVPTST('LE'))   IXTRAN = 14
       IF(XVPTST('LT'))   IXTRAN = 15
       IF(XVPTST('GE'))   IXTRAN = 16
       IF(XVPTST('GT'))   IXTRAN = 17

C*******************************************************************

C      DEFAULT THE COLS ARRAY

       DO I = 1,NC      ! GET ALL THE COLUMNS JUST CAUSE IT'S EASIER
           COLS(I) = I
       END DO

C      OPEN A RECORD = ROW

       CALL IBIS_RECORD_OPEN(IBIS,RECORDD,'FORMAT:DOUB',
     *      COLS,NC,'DOUB',ISTAT)

C      READ THROUGH ALL THE ROWS

       DO ROW = 1,NR
          CALL IBIS_RECORD_READ(RECORDD, ROWBUF, ROW, ISTAT)
          IF (ISTAT.NE.1) CALL IBIS_SIGNAL(IBIS,ISTAT,1)

          GO TO (201,202,203,204,205,206,207,208,209,210, ! DO FUNCTION
     -        211,212,213,214,215,216,217),IXTRAN

 201      CONTINUE    ! ADD
          DO I = 1, OUTCOL_COUNT
              SUM = 0.0
              DO J = 1, INCOL_COUNT
                  SUM = SUM + ROWBUF(INCOLS(J))
              END DO
          ROWBUF(OUTCOLS(I)) = SUM
          END DO
          GO TO 300

 202      CONTINUE    ! SUBTRACT
          DO I = 1, OUTCOL_COUNT
              ROWBUF(OUTCOLS(I)) = ROWBUF(INCOLS(1))-ROWBUF(INCOLS(2))
          END DO
          GO TO 300

 203      CONTINUE    ! MULTIPLY
          DO I = 1, OUTCOL_COUNT
              SUM = 1.0
              DO J = 1, INCOL_COUNT
                  SUM = SUM * ROWBUF(INCOLS(J))
              END DO
          ROWBUF(OUTCOLS(I)) = SUM
          END DO
          GO TO 300

 204      CONTINUE    ! DIVIDE
          DO I = 1, OUTCOL_COUNT
              ROWBUF(OUTCOLS(I)) = ROWBUF(INCOLS(1))/ROWBUF(INCOLS(2))
          END DO
          GO TO 300

 205      CONTINUE    ! INT
          IF (INCOL_COUNT .NE. OUTCOL_COUNT) THEN
	   CALL MABEND ('INPUT/OUTPUT COLUMN COUNT MUST BE THE SAME')
  	  ENDIF
          DO I = 1, OUTCOL_COUNT
              ROWBUF(OUTCOLS(I)) = DINT(ROWBUF(INCOLS(I)))
          END DO
          GO TO 300

 206      CONTINUE    ! ABS
          IF (INCOL_COUNT .NE. OUTCOL_COUNT) THEN
	   CALL MABEND ('INPUT/OUTPUT COLUMN COUNT MUST BE THE SAME')
  	  ENDIF
          DO I = 1, OUTCOL_COUNT
              ROWBUF(OUTCOLS(I)) = DABS(ROWBUF(INCOLS(I)))
          END DO
          GO TO 300

 207      CONTINUE    ! SQUARE ROOT
          IF (INCOL_COUNT .NE. OUTCOL_COUNT) THEN
	   CALL MABEND ('INPUT/OUTPUT COLUMN COUNT MUST BE THE SAME')
  	  ENDIF
          DO I = 1, OUTCOL_COUNT
              ROWBUF(OUTCOLS(I)) = DSQRT(ROWBUF(INCOLS(I)))
          END DO
          GO TO 300

 208      CONTINUE    ! MINIMUM
          DO I = 1, NC
              TEMP(I) = ROWBUF(I)
          END DO
          CALL MINMAX(8,NC,TEMP,DMIN,DMAX,IMIN,IMAX)
          DO I = 1, OUTCOL_COUNT
              ROWBUF(OUTCOLS(I)) = DMIN
          END DO
          GO TO 300

 209      CONTINUE    ! MAXIMUM
          DO I = 1, NC
              TEMP(I) = ROWBUF(I)
          END DO
          CALL MINMAX(8,NC,TEMP,DMIN,DMAX,IMIN,IMAX)
          DO I = 1, OUTCOL_COUNT
              ROWBUF(OUTCOLS(I)) = DMAX
          END DO
          GO TO 300

 210      CONTINUE    ! SET VALUE
          DO I = 1, OUTCOL_COUNT
              ROWBUF(OUTCOLS(I)) = VALUE
          END DO
          GO TO 300

 211      CONTINUE    ! INDEX
          DO I = 1, OUTCOL_COUNT
              ROWBUF(OUTCOLS(I)) = ROW
              ROWBUF(OUTCOLS(I)) = DINT(ROWBUF(OUTCOLS(I)))
          END DO
          GO TO 300

 212      CONTINUE    ! EQ
          DO I = 1, OUTCOL_COUNT
              IF ( ROWBUF(INCOLS(1)) .EQ. VALUE ) THEN
                   ROWBUF(OUTCOLS(I)) = 1
              ELSE
                   ROWBUF(OUTCOLS(I)) = 0
              END IF
          END DO
          GO TO 300

 213      CONTINUE    ! NE
          DO I = 1, OUTCOL_COUNT
              IF ( ROWBUF(INCOLS(1)) .NE. VALUE ) THEN
                   ROWBUF(OUTCOLS(I)) = 1
              ELSE
                   ROWBUF(OUTCOLS(I)) = 0
              END IF
          END DO
          GO TO 300

 214      CONTINUE    ! LE
          DO I = 1, OUTCOL_COUNT
              IF ( ROWBUF(INCOLS(1)) .LE. VALUE ) THEN
                   ROWBUF(OUTCOLS(I)) = 1
              ELSE
                   ROWBUF(OUTCOLS(I)) = 0
              END IF
          END DO
          GO TO 300

 215      CONTINUE    ! LT
          DO I = 1, OUTCOL_COUNT
              IF ( ROWBUF(INCOLS(1)) .LT. VALUE ) THEN
                   ROWBUF(OUTCOLS(I)) = 1
              ELSE
                   ROWBUF(OUTCOLS(I)) = 0
              END IF
          END DO
          GO TO 300

 216      CONTINUE    ! GE
          DO I = 1, OUTCOL_COUNT
              IF ( ROWBUF(INCOLS(1)) .GE. VALUE ) THEN
                   ROWBUF(OUTCOLS(I)) = 1
              ELSE
                   ROWBUF(OUTCOLS(I)) = 0
              END IF
          END DO
          GO TO 300

 217      CONTINUE    ! GT
          DO I = 1, OUTCOL_COUNT
              IF ( ROWBUF(INCOLS(1)) .GT. VALUE ) THEN
                   ROWBUF(OUTCOLS(I)) = 1
              ELSE
                   ROWBUF(OUTCOLS(I)) = 0
              END IF
          END DO

 300      CALL IBIS_RECORD_WRITE(RECORDD,ROWBUF,ROW,ISTAT)
       END DO

       CALL IBIS_RECORD_CLOSE(RECORDD,ISTAT)
       CALL IBIS_FILE_CLOSE(IBIS,' ',ISTAT)
       IF (ISTAT.NE.1) CALL IBIS_SIGNAL(IBIS,ISTAT,1)

       RETURN
       END


!! https://github.com/flang-compiler/flang/issues/254
!! Fixed in the 20190329 release
!!
!! Right shift of bits.  0 should move in from left.
!!
!! Expected output:
!!
!! $ ./a.out
!! -44=11010100
!! 106=01101010
!!
!! Output from flang:
!!
!! $ ./a.out
!! -44=11010100
!! -22=11101010

program main
  use,intrinsic :: iso_fortran_env
  integer(int8) :: digest
  digest = -44_int8
  write(*,'(i0,"=",b8.8)') digest, digest
  digest = ishft(digest,-1)
  write(*,'(i0,"=",b8.8)') digest, digest
end program


*     MC01OD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          KMAX
      PARAMETER        ( KMAX = 10 )
*     .. Local Scalars ..
      INTEGER          I, INFO, K
*     .. Local Arrays ..
      DOUBLE PRECISION DWORK(2*KMAX+2), IMP(KMAX+1), IMZ(KMAX),
     $                 REP(KMAX+1), REZ(KMAX)
*     .. External Subroutines ..
      EXTERNAL         MC01OD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) K
      IF ( K.LT.0 .OR. K.GT.KMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) K
      ELSE
         READ ( NIN, FMT = * ) ( REZ(I), IMZ(I), I = 1,K )
*        Compute the coefficients of P(x) from the given zeros.
         CALL MC01OD( K, REZ, IMZ, REP, IMP, DWORK, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 )
            WRITE ( NOUT, FMT = 99996 )
     $            ( I, REP(I+1), IMP(I+1), I = 0,K )
         END IF
      END IF
      STOP
*
99999 FORMAT (' MC01OD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01OD = ',I2)
99997 FORMAT (' The coefficients of the polynomial P(x) are ',//' powe',
     $       'r of x     real part     imag part ')
99996 FORMAT (2X,I5,8X,F9.4,5X,F9.4)
99995 FORMAT (/' K is out of range.',/' K = ',I5)
      END


subroutine sld_calcVelandAccel(a,dtinv)
    !This routine calculates vel and accel for solid probs
    use typre
    use Mod_TimeIntegrator
    use Mod_php_SetTimeIntegrator
    use Mod_Solids
    implicit none
    class(SolidsProblem)    :: a
    type(TimeIntegratorDt1) :: Integrator1
    type(TimeIntegratorDt2) :: Integrator2
    real(rp)                :: c1(10),c2(10)
    integer(ip)             :: ndime,idime,nsteps,nsteps2,i
    real(rp)                :: dtinv,dtinv2,dtime,beta,omega
    real(rp)                :: LHSdtinv2,LHSdtinv

    dtinv2=dtinv*dtinv
    dtime = 1.0_rp/dtinv

    call a%Mesh%GetNdime(ndime)

    if (a%kfl_tsche_2nd_current == 'NEWMA') then

        beta  = a%beta
        omega = a%omega

        do idime = 1,ndime

            a%accel(idime,:,1) = (dtinv2/beta)*(a%disp(idime,:,1) - a%disp(idime,:,3)) -&
                    (dtinv/beta)*a%veloc(idime,:,2) - ((1.0_rp/(2.0_rp*beta))-1.0_rp)*a%accel(idime,:,2)

            a%veloc(idime,:,1) = a%veloc(idime,:,2) + dtime*((1.0_rp-omega)*a%accel(idime,:,2) +&
                    omega*a%accel(idime,:,1))
        enddo

    else

        call php_SetTimeIntegrator(a,Integrator1,LHSdtinv,nsteps)
        call php_SetTimeIntegrator(a,Integrator2,LHSdtinv2,nsteps2)
        call Integrator1%GetTimeSchemeCoefficients(c1)
        call Integrator2%GetTimeSchemeCoefficients(c2)

        do idime = 1,ndime
            a%accel(idime,:,1) = dtinv2*c2(1)*a%disp(idime,:,1)
            a%veloc(idime,:,1) =  dtinv*c1(1)*a%disp(idime,:,1)
        end do

        do i = 2,nsteps2
            do idime = 1,ndime

                a%accel(idime,:,1) = a%accel(idime,:,1) - dtinv2*c2(i)*a%disp(idime,:,i+1)
            enddo
        enddo

        do i = 2,nsteps
            do idime = 1,ndime

                a%veloc(idime,:,1) = a%veloc(idime,:,1) - dtinv*c1(i)*a%disp(idime,:,i+1)
            enddo
        enddo

    endif

end subroutine


Function subcr7(t, u)
  Implicit Double Precision (A-H, O-Z)
  subcr7 = 9.D0/2.D0*(3.D0-t*u-u/t**2-t/u**2)
  Return
End Function subcr7


! SUMMA - Structure for Unifying Multiple Modeling Alternatives
! Copyright (C) 2014-2015 NCAR/RAL
!
! This file is part of SUMMA
!
! For more information see: http://www.ral.ucar.edu/projects/summa
!
! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.

module snow_utils_module
USE nrtype
implicit none
private
public::fracliquid
public::templiquid
public::dFracLiq_dTk
public::tcond_snow
contains

 ! ***********************************************************************************************************
 ! public function fracliquid: compute fraction of liquid water
 ! ***********************************************************************************************************
 function fracliquid(Tk,fc_param)
 USE multiconst,only:Tfreeze
 implicit none
 real(dp),intent(in) :: Tk         ! temperature (K)
 real(dp),intent(in) :: fc_param   ! freezing curve parameter (K-1)
 real(dp)            :: fracliquid ! fraction of liquid water (-)
 ! compute fraction of liquid water (-)
 fracliquid = 1._dp / ( 1._dp + (fc_param*( Tfreeze - min(Tk,Tfreeze) ))**2._dp )
 end function fracliquid

 ! ***********************************************************************************************************
 ! public function templiquid: invert the fraction of liquid water function
 ! ***********************************************************************************************************
 function templiquid(fracliquid,fc_param)
 USE multiconst,only:Tfreeze
 implicit none
 real(dp),intent(in) :: fracliquid ! fraction of liquid water (-)
 real(dp),intent(in) :: fc_param   ! freezing curve parameter (K-1)
 real(dp)            :: templiquid ! temperature (K)
 ! compute temperature based on the fraction of liquid water (K)
 templiquid = Tfreeze - ((1._dp/fracliquid - 1._dp)/fc_param**2._dp)**(0.5_dp)
 end function templiquid

 ! ***********************************************************************************************************
 ! public function dFracLiq_dTk: differentiate the freezing curve
 ! ***********************************************************************************************************
 function dFracLiq_dTk(Tk,fc_param)
 USE multiconst,only:Tfreeze
 implicit none
 ! dummies
 real(dp),intent(in) :: Tk           ! temperature (K)
 real(dp),intent(in) :: fc_param     ! freezing curve parameter (K-1)
 real(dp)            :: dFracLiq_dTk ! differentiate the freezing curve (K-1)
 ! locals
 real(dp)            :: Tdep         ! temperature depression (K)
 real(dp)            :: Tdim         ! dimensionless temperature (-)
 ! compute local variables (just to make things more efficient)
 Tdep = Tfreeze - min(Tk,Tfreeze)
 Tdim = fc_param*Tdep
 ! differentiate the freezing curve w.r.t temperature
 dFracLiq_dTk = (fc_param*2._dp*Tdim) / ( ( 1._dp + Tdim**2._dp)**2._dp )
 end function dFracLiq_dTk

 ! ***********************************************************************************************************
 ! public subroutine tcond_snow: compute thermal conductivity of snow
 ! ***********************************************************************************************************
 subroutine tcond_snow(BulkDenIce,thermlcond,err,message)
 USE multiconst,only:lambda_air,lambda_ice  ! thermal conductivity of air and ice
 USE globalData,only:model_decisions        ! model decision structure
 USE var_lookup,only:iLookDECISIONS         ! named variables for elements of the decision structure
 USE mDecisions_module,only:Yen1965,Mellor1977,Jordan1991 ! named variables defining thermal conductivity options
 implicit none
 real(dp),intent(in)      :: BulkDenIce     ! bulk density of ice (kg m-3)
 real(dp),intent(out)     :: thermlcond     ! thermal conductivity of snow (W m-1 K-1)
 integer(i4b),intent(out) :: err            ! error code
 character(*),intent(out) :: message        ! error message
 ! initialize error control
 err=0; message="tcond_snow/"
 ! compute thermal conductivity of snow
 select case(model_decisions(iLookDECISIONS%thCondSnow)%iDecision)
  case(Yen1965);      thermlcond = 3.217d-6 * BulkDenIce**2._dp               ! Yen (1965)
  case(Mellor1977);   thermlcond = 2.576d-6 * BulkDenIce**2._dp + 7.4d-2      ! Mellor (1977)
  case(Jordan1991);   thermlcond = lambda_air + (7.75d-5*BulkDenIce + 1.105d-6*(BulkDenIce**2._dp)) &
                                     * (lambda_ice-lambda_air)                ! Jordan (1991)
  case default
   err=10; message=trim(message)//"unknownOption"; return
 end select
 end subroutine tcond_snow

end module snow_utils_module


      SUBROUTINE FGAUSS(X,A,Y,DYDA,NA)
      DIMENSION A(NA),DYDA(NA)
      Y=0.
      DO 11 I=1,NA-1,3
        ARG=(X-A(I+1))/A(I+2)
        EX=EXP(-ARG**2)
        FAC=A(I)*EX*2.*ARG
        Y=Y+A(I)*EX
        DYDA(I)=EX
        DYDA(I+1)=FAC/A(I+2)
        DYDA(I+2)=FAC*ARG/A(I+2)
11    CONTINUE
      RETURN
      END


C     LAST UPDATE 04/03/97
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE FLEIB(X,A,Y,DYDA)
      IMPLICIT NONE
C
C Purpose: This subroutine calculates the LIEBLER DIBLOCK COPOLYMER
C          L.LEIBLER, Macromolecule 13(1980)1602-1617 eqns IV-2 to IV-8
C          R.K.Heenan 13/1/97
C          Modified for FIT 17/02/97 by RCD.
C          Q=X, DIBLK=Y,
C          A(1)=I0, A(2)=Q0, A(3)=LL, A(4)=RN, A(5)=F, A(6)=CHI
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Parameter:
C
      DOUBLE PRECISION TINY
      PARAMETER (TINY=1.0D-40)
C
C Arguments:
C
      DOUBLE PRECISION A(10),DYDA(10)
      DOUBLE PRECISION X,Y
C
C Local variables:
C
      DOUBLE PRECISION TA(3),DYDA1(3),DYDA2(3),DYDA3(3)
      DOUBLE PRECISION RG1,RG2,RG3,F1,F2,F3,F,FM,DEN1,DEN2,DIBLK,
     &                 DD2DF1,DD2DF2,DD2DF3,DD1DF1,DD1DF2,DD1DF3,DD2DN
C
C-----------------------------------------------------------------------
C
C========Check parameters
C
      IF(A(3).LT.TINY)A(3) = TINY
      IF(A(4).LT.1.0D0)A(4) = 1.0D0
      IF(A(5).LT.TINY)A(5) = TINY
      IF(A(5).GT.1.0D0-TINY)A(5) = 1.0D0 - TINY
      IF(A(6).LT.0.0D0)A(6) = 0.0D0
C
C========Calculate Rg's and Debye functions
C
      RG1 = A(3)*SQRT(A(4)/6.0D0)
      TA(1) = 1.0D0
      TA(2) = A(2)
      TA(3) = 1.0D0/RG1
      CALL FDEBYE(X,TA,F1,DYDA1)
      F = A(5)
      RG2 = RG1*SQRT(F)
      TA(1) = F*F
      TA(3) = 1.0D0/RG2
      CALL FDEBYE(X,TA,F2,DYDA2)
      FM = 1.0D0 - F
      RG3 = RG1*SQRT(FM)
      TA(1) = FM*FM
      TA(3) = 1.0D0/RG3
      CALL FDEBYE(X,TA,F3,DYDA3)
      DEN1 = F2*F3 - 0.25D0*(F1 - F2 - F3)**2
      IF(ABS(DEN1).LT.TINY)DEN1 = SIGN(TINY,DEN1)
      DEN2 = F1/DEN1 - 2.0D0*A(4)*A(6)
      IF(ABS(DEN2).LT.TINY)DEN2 = SIGN(TINY,DEN2)
      DIBLK = A(4)/DEN2
      Y = A(1)*DIBLK
C
C========Calculate partial derivatives
C
      DD1DF1 = -0.5D0*(F1 - F2 - F3)
      DD1DF2 = 0.5D0*(F1 - F2 + F3)
      DD1DF3 = 0.5D0*(F1 + F2 - F3)
      DD2DF1 = (DEN1 - F1*DD1DF1)/(DEN1*DEN1)
      DD2DF2 = -DD1DF2*F1/(DEN1*DEN1)
      DD2DF3 = -DD1DF3*F1/(DEN1*DEN1)
      DYDA(1) = DIBLK
      DYDA(2) = -Y/DEN2*
     &          (DD2DF1*DYDA1(2)+DD2DF2*DYDA2(2)+DD2DF3*DYDA3(2))
      DYDA(3) = Y/DEN2*
     &          (DD2DF1*DYDA1(3)/(RG1*A(3)) +
     &           DD2DF2*DYDA2(3)/(RG2*A(3)) +
     &           DD2DF3*DYDA3(3)/(RG3*A(3)))
      DD2DN = -0.5D0*(DYDA1(3)*DD2DF1/(RG1*A(4)) +
     &                DYDA2(3)*DD2DF2/(RG2*A(4)) +
     &                DYDA3(3)*DD2DF3/(RG3*A(4))) -
     &        2.0D0*A(6)
      DYDA(4) = A(1)*(DEN2 - A(4)*DD2DN)/(DEN2*DEN2)
      DYDA(5) = -Y/DEN2*
     &          (DD2DF2*(DYDA2(1)*2.0D0*F  -
     &                   DYDA2(3)/(2.0D0*RG2*F )) -
     &           DD2DF3*(DYDA3(1)*2.0D0*FM -
     &                   DYDA3(3)/(2.0D0*RG3*FM)))
      DYDA(6) = 2.0D0*A(4)*Y/DEN2
      RETURN
      END