*> \brief \b ZLAVHP
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZLAVHP( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB,
*                          INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          DIAG, TRANS, UPLO
*       INTEGER            INFO, LDB, N, NRHS
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       COMPLEX*16         A( * ), B( LDB, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>    ZLAVHP  performs one of the matrix-vector operations
*>       x := A*x  or  x := A^H*x,
*>    where x is an N element vector and  A is one of the factors
*>    from the symmetric factorization computed by ZHPTRF.
*>    ZHPTRF produces a factorization of the form
*>         U * D * U^H     or     L * D * L^H,
*>    where U (or L) is a product of permutation and unit upper (lower)
*>    triangular matrices, U^H (or L^H) is the conjugate transpose of
*>    U (or L), and D is Hermitian and block diagonal with 1 x 1 and
*>    2 x 2 diagonal blocks.  The multipliers for the transformations
*>    and the upper or lower triangular parts of the diagonal blocks
*>    are stored columnwise in packed format in the linear array A.
*>
*>    If TRANS = 'N' or 'n', ZLAVHP multiplies either by U or U * D
*>    (or L or L * D).
*>    If TRANS = 'C' or 'c', ZLAVHP multiplies either by U^H or D * U^H
*>    (or L^H or D * L^H ).
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \verbatim
*>  UPLO   - CHARACTER*1
*>           On entry, UPLO specifies whether the triangular matrix
*>           stored in A is upper or lower triangular.
*>              UPLO = 'U' or 'u'   The matrix is upper triangular.
*>              UPLO = 'L' or 'l'   The matrix is lower triangular.
*>           Unchanged on exit.
*>
*>  TRANS  - CHARACTER*1
*>           On entry, TRANS specifies the operation to be performed as
*>           follows:
*>              TRANS = 'N' or 'n'   x := A*x.
*>              TRANS = 'C' or 'c'   x := A^H*x.
*>           Unchanged on exit.
*>
*>  DIAG   - CHARACTER*1
*>           On entry, DIAG specifies whether the diagonal blocks are
*>           assumed to be unit matrices, as follows:
*>              DIAG = 'U' or 'u'   Diagonal blocks are unit matrices.
*>              DIAG = 'N' or 'n'   Diagonal blocks are non-unit.
*>           Unchanged on exit.
*>
*>  N      - INTEGER
*>           On entry, N specifies the order of the matrix A.
*>           N must be at least zero.
*>           Unchanged on exit.
*>
*>  NRHS   - INTEGER
*>           On entry, NRHS specifies the number of right hand sides,
*>           i.e., the number of vectors x to be multiplied by A.
*>           NRHS must be at least zero.
*>           Unchanged on exit.
*>
*>  A      - COMPLEX*16 array, dimension( N*(N+1)/2 )
*>           On entry, A contains a block diagonal matrix and the
*>           multipliers of the transformations used to obtain it,
*>           stored as a packed triangular matrix.
*>           Unchanged on exit.
*>
*>  IPIV   - INTEGER array, dimension( N )
*>           On entry, IPIV contains the vector of pivot indices as
*>           determined by ZSPTRF or ZHPTRF.
*>           If IPIV( K ) = K, no interchange was done.
*>           If IPIV( K ) <> K but IPIV( K ) > 0, then row K was inter-
*>           changed with row IPIV( K ) and a 1 x 1 pivot block was used.
*>           If IPIV( K ) < 0 and UPLO = 'U', then row K-1 was exchanged
*>           with row | IPIV( K ) | and a 2 x 2 pivot block was used.
*>           If IPIV( K ) < 0 and UPLO = 'L', then row K+1 was exchanged
*>           with row | IPIV( K ) | and a 2 x 2 pivot block was used.
*>
*>  B      - COMPLEX*16 array, dimension( LDB, NRHS )
*>           On entry, B contains NRHS vectors of length N.
*>           On exit, B is overwritten with the product A * B.
*>
*>  LDB    - INTEGER
*>           On entry, LDB contains the leading dimension of B as
*>           declared in the calling program.  LDB must be at least
*>           max( 1, N ).
*>           Unchanged on exit.
*>
*>  INFO   - INTEGER
*>           INFO is the error flag.
*>           On exit, a value of 0 indicates a successful exit.
*>           A negative value, say -K, indicates that the K-th argument
*>           has an illegal value.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16_lin
*
*  =====================================================================
      SUBROUTINE ZLAVHP( UPLO, TRANS, DIAG, N, NRHS, A, IPIV, B, LDB,
     $                   INFO )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          DIAG, TRANS, UPLO
      INTEGER            INFO, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         A( * ), B( LDB, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX*16         ONE
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOUNIT
      INTEGER            J, K, KC, KCNEXT, KP
      COMPLEX*16         D11, D12, D21, D22, T1, T2
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZGEMV, ZGERU, ZLACGV, ZSCAL, ZSWAP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DCONJG, MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'C' ) )
     $          THEN
         INFO = -2
      ELSE IF( .NOT.LSAME( DIAG, 'U' ) .AND. .NOT.LSAME( DIAG, 'N' ) )
     $          THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZLAVHP ', -INFO )
         RETURN
      END IF
*
*     Quick return if possible.
*
      IF( N.EQ.0 )
     $   RETURN
*
      NOUNIT = LSAME( DIAG, 'N' )
*------------------------------------------
*
*     Compute  B := A * B  (No transpose)
*
*------------------------------------------
      IF( LSAME( TRANS, 'N' ) ) THEN
*
*        Compute  B := U*B
*        where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
*
         IF( LSAME( UPLO, 'U' ) ) THEN
*
*        Loop forward applying the transformations.
*
            K = 1
            KC = 1
   10       CONTINUE
            IF( K.GT.N )
     $         GO TO 30
*
*           1 x 1 pivot block
*
            IF( IPIV( K ).GT.0 ) THEN
*
*              Multiply by the diagonal element if forming U * D.
*
               IF( NOUNIT )
     $            CALL ZSCAL( NRHS, A( KC+K-1 ), B( K, 1 ), LDB )
*
*              Multiply by P(K) * inv(U(K))  if K > 1.
*
               IF( K.GT.1 ) THEN
*
*                 Apply the transformation.
*
                  CALL ZGERU( K-1, NRHS, ONE, A( KC ), 1, B( K, 1 ),
     $                        LDB, B( 1, 1 ), LDB )
*
*                 Interchange if P(K) != I.
*
                  KP = IPIV( K )
                  IF( KP.NE.K )
     $               CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
               END IF
               KC = KC + K
               K = K + 1
            ELSE
*
*              2 x 2 pivot block
*
               KCNEXT = KC + K
*
*              Multiply by the diagonal block if forming U * D.
*
               IF( NOUNIT ) THEN
                  D11 = A( KCNEXT-1 )
                  D22 = A( KCNEXT+K )
                  D12 = A( KCNEXT+K-1 )
                  D21 = DCONJG( D12 )
                  DO 20 J = 1, NRHS
                     T1 = B( K, J )
                     T2 = B( K+1, J )
                     B( K, J ) = D11*T1 + D12*T2
                     B( K+1, J ) = D21*T1 + D22*T2
   20             CONTINUE
               END IF
*
*              Multiply by  P(K) * inv(U(K))  if K > 1.
*
               IF( K.GT.1 ) THEN
*
*                 Apply the transformations.
*
                  CALL ZGERU( K-1, NRHS, ONE, A( KC ), 1, B( K, 1 ),
     $                        LDB, B( 1, 1 ), LDB )
                  CALL ZGERU( K-1, NRHS, ONE, A( KCNEXT ), 1,
     $                        B( K+1, 1 ), LDB, B( 1, 1 ), LDB )
*
*                 Interchange if P(K) != I.
*
                  KP = ABS( IPIV( K ) )
                  IF( KP.NE.K )
     $               CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
               END IF
               KC = KCNEXT + K + 1
               K = K + 2
            END IF
            GO TO 10
   30       CONTINUE
*
*        Compute  B := L*B
*        where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
*
         ELSE
*
*           Loop backward applying the transformations to B.
*
            K = N
            KC = N*( N+1 ) / 2 + 1
   40       CONTINUE
            IF( K.LT.1 )
     $         GO TO 60
            KC = KC - ( N-K+1 )
*
*           Test the pivot index.  If greater than zero, a 1 x 1
*           pivot was used, otherwise a 2 x 2 pivot was used.
*
            IF( IPIV( K ).GT.0 ) THEN
*
*              1 x 1 pivot block:
*
*              Multiply by the diagonal element if forming L * D.
*
               IF( NOUNIT )
     $            CALL ZSCAL( NRHS, A( KC ), B( K, 1 ), LDB )
*
*              Multiply by  P(K) * inv(L(K))  if K < N.
*
               IF( K.NE.N ) THEN
                  KP = IPIV( K )
*
*                 Apply the transformation.
*
                  CALL ZGERU( N-K, NRHS, ONE, A( KC+1 ), 1, B( K, 1 ),
     $                        LDB, B( K+1, 1 ), LDB )
*
*                 Interchange if a permutation was applied at the
*                 K-th step of the factorization.
*
                  IF( KP.NE.K )
     $               CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
               END IF
               K = K - 1
*
            ELSE
*
*              2 x 2 pivot block:
*
               KCNEXT = KC - ( N-K+2 )
*
*              Multiply by the diagonal block if forming L * D.
*
               IF( NOUNIT ) THEN
                  D11 = A( KCNEXT )
                  D22 = A( KC )
                  D21 = A( KCNEXT+1 )
                  D12 = DCONJG( D21 )
                  DO 50 J = 1, NRHS
                     T1 = B( K-1, J )
                     T2 = B( K, J )
                     B( K-1, J ) = D11*T1 + D12*T2
                     B( K, J ) = D21*T1 + D22*T2
   50             CONTINUE
               END IF
*
*              Multiply by  P(K) * inv(L(K))  if K < N.
*
               IF( K.NE.N ) THEN
*
*                 Apply the transformation.
*
                  CALL ZGERU( N-K, NRHS, ONE, A( KC+1 ), 1, B( K, 1 ),
     $                        LDB, B( K+1, 1 ), LDB )
                  CALL ZGERU( N-K, NRHS, ONE, A( KCNEXT+2 ), 1,
     $                        B( K-1, 1 ), LDB, B( K+1, 1 ), LDB )
*
*                 Interchange if a permutation was applied at the
*                 K-th step of the factorization.
*
                  KP = ABS( IPIV( K ) )
                  IF( KP.NE.K )
     $               CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
               END IF
               KC = KCNEXT
               K = K - 2
            END IF
            GO TO 40
   60       CONTINUE
         END IF
*-------------------------------------------------
*
*     Compute  B := A^H * B  (conjugate transpose)
*
*-------------------------------------------------
      ELSE
*
*        Form  B := U^H*B
*        where U  = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
*        and   U^H = inv(U^H(1))*P(1)* ... *inv(U^H(m))*P(m)
*
         IF( LSAME( UPLO, 'U' ) ) THEN
*
*           Loop backward applying the transformations.
*
            K = N
            KC = N*( N+1 ) / 2 + 1
   70       CONTINUE
            IF( K.LT.1 )
     $         GO TO 90
            KC = KC - K
*
*           1 x 1 pivot block.
*
            IF( IPIV( K ).GT.0 ) THEN
               IF( K.GT.1 ) THEN
*
*                 Interchange if P(K) != I.
*
                  KP = IPIV( K )
                  IF( KP.NE.K )
     $               CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
*                 Apply the transformation:
*                    y := y - B' * conjg(x)
*                 where x is a column of A and y is a row of B.
*
                  CALL ZLACGV( NRHS, B( K, 1 ), LDB )
                  CALL ZGEMV( 'Conjugate', K-1, NRHS, ONE, B, LDB,
     $                        A( KC ), 1, ONE, B( K, 1 ), LDB )
                  CALL ZLACGV( NRHS, B( K, 1 ), LDB )
               END IF
               IF( NOUNIT )
     $            CALL ZSCAL( NRHS, A( KC+K-1 ), B( K, 1 ), LDB )
               K = K - 1
*
*           2 x 2 pivot block.
*
            ELSE
               KCNEXT = KC - ( K-1 )
               IF( K.GT.2 ) THEN
*
*                 Interchange if P(K) != I.
*
                  KP = ABS( IPIV( K ) )
                  IF( KP.NE.K-1 )
     $               CALL ZSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ),
     $                           LDB )
*
*                 Apply the transformations.
*
                  CALL ZLACGV( NRHS, B( K, 1 ), LDB )
                  CALL ZGEMV( 'Conjugate', K-2, NRHS, ONE, B, LDB,
     $                        A( KC ), 1, ONE, B( K, 1 ), LDB )
                  CALL ZLACGV( NRHS, B( K, 1 ), LDB )
*
                  CALL ZLACGV( NRHS, B( K-1, 1 ), LDB )
                  CALL ZGEMV( 'Conjugate', K-2, NRHS, ONE, B, LDB,
     $                        A( KCNEXT ), 1, ONE, B( K-1, 1 ), LDB )
                  CALL ZLACGV( NRHS, B( K-1, 1 ), LDB )
               END IF
*
*              Multiply by the diagonal block if non-unit.
*
               IF( NOUNIT ) THEN
                  D11 = A( KC-1 )
                  D22 = A( KC+K-1 )
                  D12 = A( KC+K-2 )
                  D21 = DCONJG( D12 )
                  DO 80 J = 1, NRHS
                     T1 = B( K-1, J )
                     T2 = B( K, J )
                     B( K-1, J ) = D11*T1 + D12*T2
                     B( K, J ) = D21*T1 + D22*T2
   80             CONTINUE
               END IF
               KC = KCNEXT
               K = K - 2
            END IF
            GO TO 70
   90       CONTINUE
*
*        Form  B := L^H*B
*        where L  = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
*        and   L^H = inv(L(m))*P(m)* ... *inv(L(1))*P(1)
*
         ELSE
*
*           Loop forward applying the L-transformations.
*
            K = 1
            KC = 1
  100       CONTINUE
            IF( K.GT.N )
     $         GO TO 120
*
*           1 x 1 pivot block
*
            IF( IPIV( K ).GT.0 ) THEN
               IF( K.LT.N ) THEN
*
*                 Interchange if P(K) != I.
*
                  KP = IPIV( K )
                  IF( KP.NE.K )
     $               CALL ZSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
*
*                 Apply the transformation
*
                  CALL ZLACGV( NRHS, B( K, 1 ), LDB )
                  CALL ZGEMV( 'Conjugate', N-K, NRHS, ONE, B( K+1, 1 ),
     $                        LDB, A( KC+1 ), 1, ONE, B( K, 1 ), LDB )
                  CALL ZLACGV( NRHS, B( K, 1 ), LDB )
               END IF
               IF( NOUNIT )
     $            CALL ZSCAL( NRHS, A( KC ), B( K, 1 ), LDB )
               KC = KC + N - K + 1
               K = K + 1
*
*           2 x 2 pivot block.
*
            ELSE
               KCNEXT = KC + N - K + 1
               IF( K.LT.N-1 ) THEN
*
*              Interchange if P(K) != I.
*
                  KP = ABS( IPIV( K ) )
                  IF( KP.NE.K+1 )
     $               CALL ZSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ),
     $                           LDB )
*
*                 Apply the transformation
*
                  CALL ZLACGV( NRHS, B( K+1, 1 ), LDB )
                  CALL ZGEMV( 'Conjugate', N-K-1, NRHS, ONE,
     $                        B( K+2, 1 ), LDB, A( KCNEXT+1 ), 1, ONE,
     $                        B( K+1, 1 ), LDB )
                  CALL ZLACGV( NRHS, B( K+1, 1 ), LDB )
*
                  CALL ZLACGV( NRHS, B( K, 1 ), LDB )
                  CALL ZGEMV( 'Conjugate', N-K-1, NRHS, ONE,
     $                        B( K+2, 1 ), LDB, A( KC+2 ), 1, ONE,
     $                        B( K, 1 ), LDB )
                  CALL ZLACGV( NRHS, B( K, 1 ), LDB )
               END IF
*
*              Multiply by the diagonal block if non-unit.
*
               IF( NOUNIT ) THEN
                  D11 = A( KC )
                  D22 = A( KCNEXT )
                  D21 = A( KC+1 )
                  D12 = DCONJG( D21 )
                  DO 110 J = 1, NRHS
                     T1 = B( K, J )
                     T2 = B( K+1, J )
                     B( K, J ) = D11*T1 + D12*T2
                     B( K+1, J ) = D21*T1 + D22*T2
  110             CONTINUE
               END IF
               KC = KCNEXT + ( N-K )
               K = K + 2
            END IF
            GO TO 100
  120       CONTINUE
         END IF
*
      END IF
      RETURN
*
*     End of ZLAVHP
*
      END


C$Procedure ZZELNAXX ( ellipse normal axis intercepts )

      SUBROUTINE ZZELNAXX ( A, B, LAT, XXPT, YXPT )

C$ Abstract
C
C     SPICE Private routine intended solely for the support of SPICE
C     routines. Users should not call this routine directly due
C     to the volatile nature of this routine.
C
C     Given semi-axis lengths of an ellipse and a planetodetic
C     latitude, find the X-axis and Y-axis intercepts of the normal
C     line corresponding to the point at that latitude in the right
C     (positive X) half-plane.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     DSK
C     ELLIPSE
C     GEOMETRY
C
C$ Declarations

      IMPLICIT NONE

      DOUBLE PRECISION      A
      DOUBLE PRECISION      B
      DOUBLE PRECISION      LAT
      DOUBLE PRECISION      XXPT
      DOUBLE PRECISION      YXPT

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     A          I   Ellipse's semi-axis length in the X direction.
C     B          I   Ellipse's semi-axis length in the Y direction.
C     LAT        I   Planetodetic latitude in radians.
C     XXPT       O   Normal line intercept on the X-axis.
C     YXPT       O   Normal line intercept on the Y-axis.
C
C$ Detailed_Input
C
C     A,
C     B          are, respectively, an ellipse's semi-axis lengths
C                in the X and Y directions. The ellipse lies in
C                two-dimensional Euclidean space.
C
C                Any of the relationships
C
C                   A < B,  A = B,  A > B
C
C                are allowed.
C
C
C     LAT        is a planetodetic latitude corresponding to
C                some point P on the ellipse defined by A and B,
C                where
C
C                   P(1) >= 0
C
C                Units are radians.
C
C$ Detailed_Output
C
C     XXPT       is the X-intercept of a line passing through the
C                ellipse and normal to the ellipse at the point having
C                the given latitude.
C
C                If LAT = 0 radians, XXPT is defined to be
C
C                        2
C                   A - B / A
C
C
C     YXPT       is the Y-intercept of a line passing through the
C                ellipse and normal to the ellipse at the point having
C                the given latitude.
C
C                If LAT = pi/2 radians, YXPT is defined to be
C
C                         2
C                    B - A / B
C
C                If LAT = -pi/2 radians, YXPT is defined to be
C
C                         2
C                   -B + A / B
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1)  If the X semi-axis length A is non-positive, the
C         error SPICE(NONPOSITIVEAXIS) will be signaled.
C
C     2)  If the Y semi-axis length B is non-positive, the
C         error SPICE(NONPOSITIVEAXIS) will be signaled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C
C     The outputs of this routine can be used to determine the
C     apex of a cone of constant planetodetic latitude.
C
C
C     The axis intercepts computed by this routine are defined
C     as described below.
C
C     Let M be the normal vector's slope. Let DELTAX be
C     X - XXPT. Then, given that the normal direction is
C     parallel to
C
C             2     2
C        ( X/A,  Y/B  )
C
C     we have, for non-zero DELTAX,
C
C        Y = M * DELTAX
C
C               2   2
C          = ( A / B )  * ( Y / X ) * ( X - XXPT )
C
C     So
C             2    2
C        X ( B  / A ) = X - XXPT
C
C     and
C                         2   2
C        XXPT = X ( 1 - (B / A ) )
C
C
C     The X intercept is a linear function of the X-coordinate
C     of the point on the ellipsoid. Define the intercept for
C
C        X = 0
C
C     as the limit as X -> 0 of the expression for XXPT above.
C     The expression is continuous and defined at X = 0, so
C     we can just evaluate the expression at X = 0 as for other
C     values of X.
C
C
C     Using the definition of M above, we have for non-zero X:
C
C        Y - YXPT = M * X
C
C     or
C
C        YXPT = Y - M*X
C
C                      2   2
C             = Y - ( A / B ) (Y/X) * X
C
C                           2   2
C             = Y (  1 - ( A / B )  )
C
C     As above, we define YXPT at X = 0 to be the limit as X -> 0
C     of the expression above, which is
C
C                    2   2
C        B (  1 - ( A / B )  )
C
C
C$ Examples
C
C     See usage in ZZRYXPDT.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 09-MAR-2016 (NJB)
C
C-&

C$ Index_Entries
C
C     find x and y intercepts of ellipse normal line
C
C-&

C
C     SPICELIB functions
C
      LOGICAL               RETURN

C
C     Local variables
C
      DOUBLE PRECISION      EPT    ( 3 )
      DOUBLE PRECISION      NORMAL ( 3 )

      IF ( RETURN() ) THEN
         RETURN
      END IF

      IF (  ( A .LE. 0.D0 ) .OR. ( B .LE. 0.D0 )  ) THEN

         CALL CHKIN  ( 'ZZELNAXX'                             )
         CALL SETMSG ( 'Semi-axis lengths were A = #; B = #. '
     .   //            'Both must be positive.'               )
         CALL ERRDP  ( '#',  A                                )
         CALL ERRDP  ( '#',  B                                )
         CALL SIGERR ( 'SPICE(NONPOSITIVEAXIS)'               )
         CALL CHKOUT ( 'ZZELNAXX'                             )
         RETURN

      END IF

C
C     Find the point lying on the positive X portion of the ellipsoid
C     and having the input planetodetic latitude.
C
C     To start, create a normal vector pointing in the direction
C     indicated by the latitude. We'll work in three dimensions in
C     order to take advantage of existing code. The third coordinates
C     of all participating vectors will be zero.
C
      NORMAL(1) = COS( LAT )
      NORMAL(2) = SIN( LAT )
      NORMAL(3) = 0.D0

      CALL EDNMPT ( A, B, B, NORMAL, EPT )

C
C     Compute the X-axis and Y-axis intercepts of the line
C     passing through EPT and parallel to a normal vector
C     at EPT. Refer to the Particulars above for details.
C
      XXPT = (  1.D0 - ( (B/A)**2 )  ) * EPT(1)

      YXPT = (  1.D0 - ( (A/B)**2 )  ) * EPT(2)

      RETURN
      END


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 2015 Adrian Martinez Vargas                            %
!                                                                      %
! This software may be modified and distributed under the terms        %
! of the MIT license.  See the LICENSE.txt file for details.           %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
! Junior University.  All rights reserved.                             %
!                                                                      %
! The programs in GSLIB are distributed in the hope that they will be  %
! useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
! responsibility to anyone for the consequences of using them or for   %
! whether they serve any particular purpose or work at all, unless he  %
! says so in writing.  Everyone is granted permission to copy, modify  %
! and redistribute the programs in GSLIB, but only under the condition %
! that this notice and the above copyright notice remain intact.       %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!-----------------------------------------------------------------------
!
! The functions and subroutines below were modified from the
! version 2.0 of the gslib code written in fortran 77
!
! The objective is to add functionality to GSLIB and to link
! this code with python using f2py. It uses f90 code convention.
! The arrays are dynamic and externally declared (from python)
!
! the code was converted from Fortran 77 to Fortran 90 using F2F.pl
!
! for more information please refer to:
! - gslib77 source code: http://www.statios.com/software/gslib77_ls.tar.gz
! - GSLIB: Geostatistical Software Library and User's Guide. Second edition
!   by Clayton V. Deutsch, Andre G. Journel, 1997.
! - F2PY Users Guide: http://docs.scipy.org/doc/numpy-dev/f2py/
! - F2F https://bitbucket.org/lemonlab/f2f
!-----------------------------------------------------------------------
subroutine bicalib(ndp,vval,nd,u,v,wt, ncutu, cutu, ncutv, cutv, &
                  ssqu, avgu, umin, umax, ssqv, avgv, vmin, vmax, &
                  pdfrep, fract, yx, em, vm, nm, b,&
                  lcdf, error)
    !-----------------------------------------------------------------------

    !               Calibration for Markov/Bayes Simulation
    !               ***************************************

    ! This program calibrates a set of primary and secondary data for input
    ! to the ``mbsim'' program.  Collocated primary (u) and secondary (v)
    ! samples are input data and the output is the local prior cdfs for the
    ! primary variable (u) given that the secondary variable (v) belongs to
    ! specific classes.  Other calibration information is also written
    ! to the output file.

    ! The program is executed with no command line arguments.  The user
    ! will be prompted for the name of a parameter file.  The parameter
    ! file is described in the documentation (see the example bicalib.par)

    ! DIMENSIONING PARAMETERS:

    !      nDAT       maximum number of calibration data
    !      nUCUT       maximum number of cutoffs on u
    !      nVCUT       maximum number of cutoffs on v

    ! Original: H. Zhu                                   Date:     July 1990
    !-----------------------------------------------------------------------

    implicit none

    ! input
    integer, intent(in) :: ndp,nd,ncutu,ncutv
    real, intent(in), dimension(ndp) :: vval        !data
    real, intent(in), dimension(nd) :: u,v,wt       !auxiliar demse file
    real, intent(in), dimension(ncutu) :: cutu
    real, intent(in), dimension(ncutv) :: cutv

    ! output
    !   primary
    real, intent (out) :: ssqu, avgu, umin, umax !variance, average, minimum, maximum
    !   secundary
    real, intent (out) :: ssqv, avgv, vmin, vmax !variance, average, minimum, maximum
    !  error
    integer, intent(out) :: error
    !  report output table
    real, intent(out), dimension(ncutu):: fract, b
    real, intent(out), dimension(ncutv+1,ncutu+1) :: pdfrep, yx
    real, intent(out), dimension(ncutu,0:1) :: em, vm
    integer, intent(out), dimension(ncutu,0:1) :: nm
    real, intent(out), dimension(ndp,ncutu):: lcdf

    ! internal

    real :: pdf(ncutv+1,ncutu+1), soft(ncutu,0:1,nd), softw(ncutu,0:1,nd)
    integer :: i, j, icls, k, n
    real :: cum, dev, sum, xd
    real, dimension(0:ncutu+1) :: ucut
    real, dimension(0:ncutv+1) :: vcut

    ! Initialize for some statistics:

    avgu = 0.0
    avgv = 0.0
    ssqu = 0.0
    ssqv = 0.0
    umin = 1.0e10
    vmin = 1.0e10
    umax =-1.0e10
    vmax =-1.0e10
    sum  = 0.0

    do i=1, ncutu
        ucut (i) = cutu(i)
    end do
    do i=1, ncutv
        vcut (i) = cutv(i)
    end do

    ! Read in as much data as the allocated storage will allow:

    do i=1, nd
        sum  = sum  + wt(i)
        avgu = avgu + u(i)*wt(i)
        avgv = avgv + v(i)*wt(i)
        ssqv = ssqv + v(i)*v(i)*wt(i)
        ssqu = ssqu + u(i)*u(i)*wt(i)
        if(u(i) < umin) umin = u(i)
        if(v(i) < vmin) vmin = v(i)
        if(u(i) > umax) umax = u(i)
        if(v(i) > vmax) vmax = v(i)
    end do

    ! There has to be at least two data to go ahead with calibration:

    if(nd <= 1 .OR. sum <= 0.001) then
        error = 10 ! 'TOO FEW DATA to go ahead  or  sum of weights too small
        stop
    endif

    ! write(*,*) 'Calculating the calibration parameters'

    xd = 1.0 / real(sum)

    ! Compute the averages and variances as an error check for the user:

    avgu = avgu * xd
    avgv = avgv * xd
    ssqu = ssqu * xd - avgu * avgu
    ssqv = ssqv * xd - avgv * avgv

    ! Establish lower and upper bounds:

    ucut(0)       = umin - 1. - abs(umax)
    ucut(ncutu+1) = umax + abs(umax+1.)
    vcut(0)       = vmin - 1. - abs(vmax)
    vcut(ncutv+1) = vmax + abs(vmax+1.)
    do i=1,ncutu
        fract(i)  = 0.0
    end do

    ! Calculate the indicator mean for each cutoff:

    do i=1,nd
        do j=1,ncutu
            if((u(i) > ucut(j-1)) .AND. (u(i) <= ucut(j)))then
                fract(j)=fract(j)+wt(i)
                go to 2
            endif
        end do
        2 continue
    end do

   ! Turn fract() into a cdf:

    i  = 1
    fract(i) = fract(i) * xd
    do i=2,ncutu
        fract(i) = fract(i-1) + fract(i) * xd
    end do

   ! Compute the pdf table:

    do k=1,ncutv+1
        do j=1,ncutu+1
            pdf(k,j) = 0.0
            pdfrep(k,j) = 0.0
        end do
    end do
    do i=1,nd
        do k=1,ncutv+1
            if((v(i) > vcut(k-1)) .AND. (v(i) <= vcut(k)))then
                do j=1,ncutu+1
                    if((u(i) > ucut(j-1)) .AND. (u(i) <= ucut(j)))then
                        pdf(k,j) = pdf(k,j) + wt(i)
                        go to 6
                    endif
                end do
            endif
        end do
        6 continue
    end do

    ! Turn the bivariate pdf into conditional cdf, i.e. the local prior cdf

    do i=1,ncutv+1
        do j=1,ncutu+1
            pdf(i,j) = pdf(i,j) * xd
            pdfrep(i,j) =pdf(i,j)
        end do
    end do

    ! Loop over all the v cutoffs:

    do i=1,ncutv+1
        cum = 0.0
        do j=1,ncutu+1
            cum = cum + pdf(i,j)
        end do
        if(cum > 0.0) then
            do j=1,ncutu+1
                pdf(i,j) = pdf(i,j) / cum
            end do
        endif
        do j=1,ncutu+1
            yx(i,j) = 0.0
            do k=1,j
                yx(i,j) = yx(i,j) + pdf(i,k)
            end do
        end do
    end do

    ! Calculate the calibration parameters from the local prior cdf table
    ! and the input data:  First, initialize counters:

    do j=1,ncutu
        do k=0,1
            nm(j,k)   = 0
            em(j,k)   = 0.0
            vm(j,k)   = 0.0
            do n=1,nd
                soft(j,k,n)  = 0.0
                softw(j,k,n) = 0.0
            end do
        end do
    end do

    ! MAIN Loop over all the u cutoffs to sort out the classification of
    ! all the data:

    do j=1,ncutu

    ! Now, loop over all the data:

        do i=1,nd
            if(u(i) <= ucut(j))then
                do k=1,ncutv+1
                    if((v(i) > vcut(k-1)) .AND. &
                    (v(i) <= vcut(k)))  then
                        nm(j,1)            = nm(j,1) + 1
                        soft(j,1,nm(j,1))  = yx(k,j)
                        softw(j,1,nm(j,1)) = wt(i)
                        go to 11
                    endif
                end do
            else
                do k=1,ncutv+1
                    if((v(i) > vcut(k-1)) .AND. &
                    (v(i) <= vcut(k)))  then
                        nm(j,0)            = nm(j,0) + 1
                        soft(j,0,nm(j,0))  = yx(k,j)
                        softw(j,0,nm(j,0)) = wt(i)
                        go to 11
                    endif
                end do
            endif
            11 continue
        end do
    end do

    ! Now, get some statistics on the calibration.  Loop over all the u
    ! cutoffs and then the two classication categories:

    do j=1,ncutu
        do k=0,1
            if(nm(j,k) >= 1) then
                em(j,k) = 0.0
                sum     = 0.0
                do i=1,nm(j,k)
                    em(j,k) = em(j,k) + soft(j,k,i)* &
                    softw(j,k,i)
                    sum     = sum     + softw(j,k,i)
                end do
                em(j,k) = em(j,k) / max(real(sum),0.000001)
                vm(j,k) = 0.0
                sum     = 0.0
                do i=1,nm(j,k)
                    dev     = soft(j,k,i) - em(j,k)
                    vm(j,k) = vm(j,k) + dev*dev* &
                    softw(j,k,i)
                    sum     = sum     + softw(j,k,i)
                end do
                vm(j,k) = vm(j,k) / max(real(sum),0.000001)
            endif
        end do
    end do

    ! Hardness coefficients:

    do j=1,ncutu
        b(j)   = em(j,1) - em(j,0)
        if(nm(j,1) < 1 .OR. nm(j,0) < 1) b(j) = -9.0
    end do

    ! Loop through all observations in the input file:

    do j=1, ndp
        do i=1,ncutv+1
            if((vval(j) > vcut(i-1)) .AND. (vval(j) <= vcut(i))) then
                icls = i
                go to 42
            endif
        end do
        42 continue
        do i=1,ncutu
            lcdf(j,i) = yx(icls,i)
        end do
    end do

end subroutine bicalib


c
c	transformation matrix t2=<lamdas,Z>*<epsilon,X>
c
c	iverse = 1 straight transform
c	      =-1 inverse transform
c
	subroutine t2(itime,x_in,x_out,iverse)
	real x_in(3),x_out(3),m,cgamma,lamdas,epsilon
	real temp(3),ut,tt0,t0
	integer*4 itime(2),iyr,iday,iverse
	parameter (degrad=3.1415927/180.0)
c
	tt0=t0(itime,iyr,iday,ut)
	epsilon=(23.439-0.013*tt0)*degrad
	m=(357.528+35999.05*tt0+0.04107*ut)*degrad
	cgamma=280.46+36000.772*tt0+0.04107*ut
	lamdas=(cgamma+(1.915-0.0048*tt0)*sin(m)+0.02*sin(2.0*m))*degrad
c
	if (iverse.eq.1) then
	  call rotate_x (epsilon,x_in,temp)
	  call rotate_z (lamdas,temp,x_out)
	else
	  call rotate_z (iverse*lamdas,x_in,temp)
	  call rotate_x (iverse*epsilon,temp,x_out)
	end if
c
	return
	end


! The kind of code only a scientist could love.
! TODO: The cape routine needs work to remove the GOTOs

!======================================================================
!
! !IROUTINE: TVIRTUAL -- Calculate virtual temperature (K)
!
! !DESCRIPTION:
!
!   This function returns a single value of virtual temperature in
!   K, given temperature in K and mixing ratio in kg/kg.  For an
!   array of virtual temperatures, use subroutine VIRTUAL_TEMP.
!
! !INPUT:
!    RATMIX - water vapor mixing ratio (kg/kg)
!    TEMP   - temperature (K)
!
! !OUTPUT:
!    TV     - Virtual temperature (K)
!

REAL(KIND=8) FUNCTION tvirtual(temp,ratmix)
    IMPLICIT NONE
    REAL(KIND=8),INTENT(IN) :: temp,ratmix
    REAL(KIND=8),PARAMETER :: EPS = .622D0

    tvirtual = temp*(EPS + ratmix)/(EPS*(1.D0 + ratmix))
    RETURN
END FUNCTION tvirtual

REAL(KIND=8) FUNCTION tonpsadiabat(thte,prs,PSADITHTE,PSADIPRS,PSADITMK,GAMMA,&
                                    throw_exception)
    IMPLICIT NONE
    EXTERNAL throw_exception
    REAL(KIND=8),INTENT(IN) :: thte
    REAL(KIND=8),INTENT(IN) :: prs
    REAL(KIND=8),DIMENSION(150),INTENT(IN) :: PSADITHTE
    REAL(KIND=8),DIMENSION(150),INTENT(IN) :: PSADIPRS
    REAL(KIND=8),DIMENSION(150,150),INTENT(IN) :: PSADITMK
    REAL(KIND=8),INTENT(IN) :: GAMMA

    REAL(KIND=8) :: fracjt
    REAL(KIND=8) :: fracjt2
    REAL(KIND=8) :: fracip
    REAL(KIND=8) :: fracip2

    INTEGER :: ip, ipch, jt, jtch

    !   This function gives the temperature (in K) on a moist adiabat
    !   (specified by thte in K) given pressure in hPa.  It uses a
    !   lookup table, with data that was generated by the Bolton (1980)
    !   formula for theta_e.

    !     First check if pressure is less than min pressure in lookup table.
    !     If it is, assume parcel is so dry that the given theta-e value can
    !     be interpretted as theta, and get temperature from the simple dry
    !     theta formula.

    IF (prs.LE.PSADIPRS(150)) THEN
      tonpsadiabat = thte * (prs/1000.D0)**GAMMA
      RETURN
    END IF

    !   Otherwise, look for the given thte/prs point in the lookup table.

    jt = -1
    DO jtch = 1,150 - 1
      IF (thte .GE. PSADITHTE(jtch) .AND. thte .LT. PSADITHTE(jtch+1)) THEN
          jt = jtch
          EXIT
          !GO TO 213
      END IF
    END DO

!    JT = -1
!213 CONTINUE
    ip = -1
    DO ipch = 1,150 - 1
      IF (prs.LE.PSADIPRS(ipch) .AND. prs.GT.PSADIPRS(ipch+1)) THEN
          ip = ipch
          EXIT
          !GO TO 215
      END IF
    END DO

!    IP = -1
!215 CONTINUE
    IF (jt.EQ.-1 .OR. ip.EQ.-1) THEN
        ! Need an exception here
        CALL throw_exception('capecalc3d: ','Outside of lookup table bounds. prs,thte=',prs,thte)
        !STOP
    END IF
    fracjt = (thte-PSADITHTE(jt)) / (PSADITHTE(jt+1)-PSADITHTE(jt))
    fracjt2 = 1.D0 - fracjt
    fracip = (PSADIPRS(ip)-prs) / (PSADIPRS(ip)-PSADIPRS(ip+1))
    fracip2 = 1.D0 - fracip
    IF (PSADITMK(ip,jt) .GT. 1D9 .OR. PSADITMK(ip+1,jt) .GT. 1D9 .OR. &
        PSADITMK(ip,jt+1) .GT. 1D9 .OR. PSADITMK(ip+1,jt+1) .GT. 1D9) THEN
        CALL throw_exception('capecalc3d: ','Tried to access missing temperature in lookup table.',&
        'Prs and Thte probably unreasonable. prs,thte=',prs,thte)
      !STOP
    END IF
    tonpsadiabat = fracip2*fracjt2*PSADITMK(ip,jt)+fracip*fracjt2*PSADITMK(ip+1,jt)+&
            fracip2*fracjt*PSADITMK(ip,jt+1)+fracip*fracjt*PSADITMK(ip+1,jt+1)

    RETURN
END FUNCTION tonpsadiabat

!     Historically, this routine calculated the pressure at full sigma
!     levels when RIP was specifically designed for MM4/MM5 output.
!     With the new generalized RIP (Feb '02), this routine is still
!     intended to calculate a set of pressure levels that bound the
!     layers represented by the vertical grid points, although no such
!     layer boundaries are assumed to be defined.  The routine simply
!     uses the midpoint between the pressures of the vertical grid
!     points as the bounding levels.  The array only contains mkzh
!     levels, so the pressure of the top of the uppermost layer is
!     actually excluded.  The kth value of pf is the lower bounding
!     pressure for the layer represented by kth data level.  At the
!     lower bounding level of the lowest model layer, it uses the
!     surface pressure, unless the data set is pressure-level data, in
!     which case it assumes the lower bounding pressure level is as far
!     below the lowest vertical level as the upper bounding pressure
!     level is above.
SUBROUTINE dpfcalc(prs,sfp,pf,miy,mjx,mkzh,ter_follow)

    REAL(KIND=8),DIMENSION(miy,mjx,mkzh),INTENT(IN) :: prs
    REAL(KIND=8),DIMENSION(miy,mjx),INTENT(IN) :: sfp
    REAL(KIND=8),DIMENSION(miy,mjx,mkzh),INTENT(OUT) :: pf
    INTEGER,INTENT(IN) :: ter_follow,miy,mjx,mkzh

    INTEGER :: i,j,k

    !  do j=1,mjx-1  Artifact of MM5
    DO j = 1,mjx
    !  do i=1,miy-1  staggered grid
      DO i = 1,miy
          DO k = 1,mkzh
              IF (k .EQ. mkzh) THEN
    !  terrain-following data
                  IF (ter_follow .EQ. 1) THEN
                      pf(i,j,k) = sfp(i,j)
    !  pressure-level data
                  ELSE
                      pf(i,j,k) = .5D0 * (3.D0*prs(i,j,k) - prs(i,j,k-1))
                  END IF
              ELSE
                  pf(i,j,k) = .5D0 * (prs(i,j,k+1) + prs(i,j,k))
              END IF
          END DO
      END DO
    END DO

    RETURN
END SUBROUTINE dpfcalc

!======================================================================
!
! !IROUTINE: capecalc3d -- Calculate CAPE and CIN
!
! !DESCRIPTION:
!
!   If i3dflag=1, this routine calculates CAPE and CIN (in m**2/s**2,
!   or J/kg) for every grid point in the entire 3D domain (treating
!   each grid point as a parcel).  If i3dflag=0, then it
!   calculates CAPE and CIN only for the parcel with max theta-e in
!   the column, (i.e. something akin to Colman's MCAPE).  By "parcel",
!   we mean a 500-m deep parcel, with actual temperature and moisture
!   averaged over that depth.
!
!   In the case of i3dflag=0,
!   CAPE and CIN are 2D fields that are placed in the k=mkzh slabs of
!   the cape and cin arrays.  Also, if i3dflag=0, LCL and LFC heights
!   are put in the k=mkzh-1 and k=mkzh-2 slabs of the cin array.
!

! Important!  The z-indexes must be arranged so that mkzh (max z-index) is the
! surface pressure.  So, pressure must be ordered in ascending order before
! calling this routine.  Other variables must be ordered the same (p,tk,q,z).

! Also, be advised that missing data values are not checked during the computation.
! Also also, Pressure must be hPa
!
SUBROUTINE f_computecape(prs,tmk,qvp,ght,ter,sfp,cape,cin,&
            PSADITHTE,PSADIPRS,PSADITMK,cmsg,i3dflag,ter_follow,&
            throw_exception,miy,mjx,mkzh)

    IMPLICIT NONE
    EXTERNAL throw_exception
    INTEGER,INTENT(IN) :: miy,mjx,mkzh,i3dflag,ter_follow
    REAL(KIND=8),DIMENSION(miy,mjx,mkzh),INTENT(IN) :: prs
    REAL(KIND=8),DIMENSION(miy,mjx,mkzh),INTENT(IN) :: tmk
    REAL(KIND=8),DIMENSION(miy,mjx,mkzh),INTENT(IN) :: qvp
    REAL(KIND=8),DIMENSION(miy,mjx,mkzh),INTENT(IN) :: ght
    REAL(KIND=8),DIMENSION(miy,mjx),INTENT(IN) :: ter
    REAL(KIND=8),DIMENSION(miy,mjx),INTENT(IN) ::sfp
    REAL(KIND=8),DIMENSION(miy,mjx,mkzh),INTENT(INOUT) :: cape
    REAL(KIND=8),DIMENSION(miy,mjx,mkzh),INTENT(INOUT) :: cin
    REAL(KIND=8),DIMENSION(150),INTENT(IN) :: PSADITHTE,PSADIPRS
    REAL(KIND=8),DIMENSION(150,150),INTENT(IN) :: PSADITMK
    REAL(KIND=8),INTENT(IN) :: cmsg

    ! local variables
    INTEGER :: i,j,k,ilcl,kel,kk,klcl,klev,klfc,kmax,kpar,kpar1,kpar2
    REAL(KIND=8) :: davg,ethmax,q,t,p,e,eth,tlcl,zlcl
    REAL(KIND=8) :: pavg,tvirtual,p1,p2,pp1,pp2,th,totthe,totqvp,totprs
    REAL(KIND=8) :: cpm,deltap,ethpari,gammam,ghtpari,qvppari,prspari,tmkpari
    REAL(KIND=8) :: facden,fac1,fac2,qvplift,tmklift,tvenv,tvlift,ghtlift
    REAL(KIND=8) :: eslift,tmkenv,qvpenv,tonpsadiabat
    REAL(KIND=8) :: benamin,dz,pup,pdn
    REAL(KIND=8),DIMENSION(150) :: buoy,zrel,benaccum
    REAL(KIND=8),DIMENSION(miy,mjx,mkzh) :: prsf

    ! constants
    INTEGER,PARAMETER :: IUP = 6
    REAL(KIND=8),PARAMETER :: CELKEL = 273.15d0
    REAL(KIND=8),PARAMETER :: GRAV = 9.81d0
    ! hpa
    REAL(KIND=8),PARAMETER :: EZERO = 6.112d0
    REAL(KIND=8),PARAMETER :: ESLCON1 = 17.67d0
    REAL(KIND=8),PARAMETER :: ESLCON2 = 29.65d0
    REAL(KIND=8),PARAMETER :: EPS = 0.622d0
    ! j/k/kg
    REAL(KIND=8),PARAMETER :: RGAS = 287.04d0
    !  j/k/kg  note: not using bolton's value of 1005.7
    REAL(KIND=8),PARAMETER :: CP = 1004.d0
    REAL(KIND=8),PARAMETER :: GAMMA = RGAS/CP
    !  cp_moist=cp*(1.+cpmd*qvp)
    REAL(KIND=8),PARAMETER :: CPMD = .887d0
    !  rgas_moist=rgas*(1.+rgasmd*qvp)
    REAL(KIND=8),PARAMETER :: RGASMD = .608d0
    !  gamma_moist=gamma*(1.+gammamd*qvp)
    REAL(KIND=8),PARAMETER :: GAMMAMD = RGASMD - CPMD
    REAL(KIND=8),PARAMETER :: TLCLC1 = 2840.d0
    REAL(KIND=8),PARAMETER :: TLCLC2 = 3.5d0
    REAL(KIND=8),PARAMETER :: TLCLC3 = 4.805d0
    REAL(KIND=8),PARAMETER :: TLCLC4 = 55.d0
    !  k
    REAL(KIND=8),PARAMETER :: THTECON1 = 3376.d0
    REAL(KIND=8),PARAMETER :: THTECON2 = 2.54d0
    REAL(KIND=8),PARAMETER :: THTECON3 = .81d0

    ! To get rid of compiler warnings
    tmkpari = 0
    qvppari = 0
    klev = 0
    klcl = 0

    ! the comments were taken from a mark stoelinga email, 23 apr 2007,
    ! in response to a user getting the "outside of lookup table bounds"
    ! error message.

    ! tmkpari  - initial temperature of parcel, k
    !    values of 300 okay. (not sure how much from this you can stray.)

    ! prspari - initial pressure of parcel, hpa
    !    values of 980 okay. (not sure how much from this you can stray.)

    ! thtecon1, thtecon2, thtecon3
    !     these are all constants, the first in k and the other two have
    !     no units.  values of 3376, 2.54, and 0.81 were stated as being
    !     okay.

    ! tlcl - the temperature at the parcel's lifted condensation level, k
    !        should be a reasonable atmospheric temperature around 250-300 k
    !        (398 is "way too high")

    ! qvppari - the initial water vapor mixing ratio of the parcel,
    !           kg/kg (should range from 0.000 to 0.025)
    !

    !  calculated the pressure at full sigma levels (a set of pressure
    !  levels that bound the layers represented by the vertical grid points)

    CALL dpfcalc(prs,sfp,prsf,miy,mjx,mkzh,ter_follow)

    !  before looping, set lookup table for getting temperature on
    !  a pseudoadiabat.

    !call dlookup_table(psadithte,psadiprs,psaditmk,psafile)

    !   do j=1,mjx-1
    DO j = 1,mjx
    !   do i=1,miy-1
      DO i = 1,miy
          cape(i,j,1) = 0.d0
          cin(i,j,1) = 0.d0

          IF (i3dflag .EQ. 1) THEN
              kpar1 = 2
              kpar2 = mkzh
          ELSE
              ! find parcel with max theta-e in lowest 3 km agl.
              ethmax = -1.d0
              DO k = mkzh,1,-1
                  IF (ght(i,j,k)-ter(i,j) .LT. 3000.d0) THEN
                      q = MAX(qvp(i,j,k), 1.d-15)
                      t = tmk(i,j,k)
                      p = prs(i,j,k)
                      e = q*p/(EPS + q)
                      tlcl = TLCLC1/ (LOG(t**TLCLC2/e)-TLCLC3) + TLCLC4
                      eth = t * (1000.d0/p)**(GAMMA*(1.d0 + GAMMAMD*q))*&
                              EXP((THTECON1/tlcl - THTECON2)*q*(1.d0 + THTECON3*q))
                      IF (eth .GT. ethmax) THEN
                          klev = k
                          ethmax = eth
                      END IF
                  END IF
              END DO
              kpar1 = klev
              kpar2 = klev

              ! Establish average properties of that parcel
              ! (over depth of approximately davg meters)

              ! davg=.1
              davg = 500.d0
              pavg = davg*prs(i,j,kpar1)*&
                  GRAV/(RGAS*tvirtual(tmk(i,j,kpar1), qvp(i,j,kpar1)))
              p2 = MIN(prs(i,j,kpar1)+.5d0*pavg, prsf(i,j,mkzh))
              p1 = p2 - pavg
              totthe = 0.d0
              totqvp = 0.d0
              totprs = 0.d0
              DO k = mkzh,2,-1
                  IF (prsf(i,j,k) .LE. p1) GOTO 35
                  IF (prsf(i,j,k-1) .GE. p2) GOTO 34
                  p = prs(i,j,k)
                  pup = prsf(i,j,k)
                  pdn = prsf(i,j,k-1)
                  q = MAX(qvp(i,j,k),1.d-15)
                  th = tmk(i,j,k)*(1000.d0/p)**(GAMMA*(1.d0 + GAMMAMD*q))
                  pp1 = MAX(p1,pdn)
                  pp2 = MIN(p2,pup)
                  IF (pp2 .GT. pp1) THEN
                      deltap = pp2 - pp1
                      totqvp = totqvp + q*deltap
                      totthe = totthe + th*deltap
                      totprs = totprs + deltap
                  END IF
    34        CONTINUE
              END DO
    35        CONTINUE
              qvppari = totqvp/totprs
              tmkpari = (totthe/totprs)*&
                  (prs(i,j,kpar1)/1000.d0)**(GAMMA*(1.d0+GAMMAMD*qvp(i,j,kpar1)))
          END IF

          DO kpar = kpar1,kpar2

              ! Calculate temperature and moisture properties of parcel
              ! (note, qvppari and tmkpari already calculated above for 2d case.)

              IF (i3dflag .EQ. 1) THEN
                  qvppari = qvp(i,j,kpar)
                  tmkpari = tmk(i,j,kpar)
              END IF
              prspari = prs(i,j,kpar)
              ghtpari = ght(i,j,kpar)
              gammam = GAMMA * (1.d0 + GAMMAMD*qvppari)
              cpm = CP * (1.d0 + CPMD*qvppari)

              e = MAX(1.d-20,qvppari*prspari/(EPS + qvppari))
              tlcl = TLCLC1/(LOG(tmkpari**TLCLC2/e) - TLCLC3) + TLCLC4
              ethpari = tmkpari*(1000.d0/prspari)**(GAMMA*(1.d0 + GAMMAMD*qvppari))*&
                  EXP((THTECON1/tlcl - THTECON2)*qvppari*(1.d0 + THTECON3*qvppari))
              zlcl = ghtpari + (tmkpari - tlcl)/(GRAV/cpm)

              ! Calculate buoyancy and relative height of lifted parcel at
              ! all levels, and store in bottom up arrays.  add a level at the lcl,
              ! and at all points where buoyancy is zero.
              !
              ! For arrays that go bottom to top
              kk = 0
              ilcl = 0

              IF (ghtpari .GE. zlcl) THEN
                  ! Initial parcel already saturated or supersaturated.
                  ilcl = 2
                  klcl = 1
              END IF

              DO k = kpar,1,-1
                  ! For arrays that go bottom to top
    33            kk = kk + 1

                  ! Model level is below lcl
                  IF (ght(i,j,k).lt.zlcl) THEN
                      qvplift = qvppari
                      tmklift = tmkpari - GRAV/cpm*(ght(i,j,k) - ghtpari)
                      tvenv = tvirtual(tmk(i,j,k), qvp(i,j,k))
                      tvlift = tvirtual(tmklift, qvplift)
                      ghtlift = ght(i,j,k)
                  ELSE IF (ght(i,j,k) .GE. zlcl .AND. ilcl .EQ. 0) THEN
                      ! This model level and previous model level straddle the lcl,
                      ! so first create a new level in the bottom-up array, at the lcl.
                      tmklift = tlcl
                      qvplift = qvppari
                      facden = ght(i,j,k) - ght(i,j,k+1)
                      fac1 = (zlcl-ght(i,j,k+1))/facden
                      fac2 = (ght(i,j,k)-zlcl)/facden
                      tmkenv = tmk(i,j,k+1)*fac2 + tmk(i,j,k)*fac1
                      qvpenv = qvp(i,j,k+1)*fac2 + qvp(i,j,k)*fac1
                      tvenv = tvirtual(tmkenv, qvpenv)
                      tvlift = tvirtual(tmklift, qvplift)
                      ghtlift = zlcl
                      ilcl = 1
                  ELSE
                      tmklift = tonpsadiabat(ethpari, prs(i,j,k), PSADITHTE, PSADIPRS,&
                                             PSADITMK, GAMMA, throw_exception)
                      eslift = EZERO*EXP(ESLCON1*(tmklift - CELKEL)/(tmklift - ESLCON2))
                      qvplift = EPS*eslift/(prs(i,j,k) - eslift)
                      tvenv = tvirtual(tmk(i,j,k), qvp(i,j,k))
                      tvlift = tvirtual(tmklift, qvplift)
                      ghtlift = ght(i,j,k)
                  END IF
                  !  Buoyancy
                  buoy(kk) = GRAV*(tvlift - tvenv)/tvenv
                  zrel(kk) = ghtlift - ghtpari

                  IF ((kk .GT. 1) .AND. (buoy(kk)*buoy(kk-1) .LT. 0.0d0)) THEN
                      ! Parcel ascent curve crosses sounding curve, so create a new level
                      ! in the bottom-up array at the crossing.
                      kk = kk + 1
                      buoy(kk) = buoy(kk-1)
                      zrel(kk) = zrel(kk-1)
                      buoy(kk-1) = 0.d0
                      zrel(kk-1) = zrel(kk-2) + buoy(kk-2)/&
                          (buoy(kk-2) - buoy(kk))*(zrel(kk) - zrel(kk-2))
                  END IF

                  IF (ilcl .EQ. 1) THEN
                      klcl = kk
                      ilcl = 2
                      GOTO 33
                  END IF
              END DO

              kmax = kk
              IF (kmax .GT. 150) THEN
                  ! Need an exception here
                  CALL throw_exception('capecalc3d: kmax got too big. kmax=',kmax)
                  !STOP
              END IF

              ! If no lcl was found, set klcl to kmax.  it is probably not really
              ! at kmax, but this will make the rest of the routine behave
              ! properly.
              IF (ilcl .EQ. 0) klcl=kmax

              ! Get the accumulated buoyant energy from the parcel's starting
              ! point, at all levels up to the top level.
              benaccum(1) = 0.0d0
              benamin = 9d9
              DO k = 2,kmax
                  dz = zrel(k) - zrel(k-1)
                  benaccum(k) = benaccum(k-1) + .5d0*dz*(buoy(k-1) + buoy(k))
                  IF (benaccum(k) .LT. benamin) THEN
                      benamin = benaccum(k)
                  END IF
              END DO

              ! Determine equilibrium level (el), which we define as the highest
              ! level of non-negative buoyancy above the lcl. note, this may be
              ! the top level if the parcel is still buoyant there.

              DO k = kmax,klcl,-1
                  IF (buoy(k) .GE. 0.d0) THEN
                      ! k of equilibrium level
                      kel = k
                      GOTO 50
                  END IF
              END DO

              ! If we got through that loop, then there is no non-negative
              ! buoyancy above the lcl in the sounding.  in these situations,
              ! both cape and cin will be set to -0.1 j/kg. (see below about
              ! missing values in v6.1.0). also, where cape is
              ! non-zero, cape and cin will be set to a minimum of +0.1 j/kg, so
              ! that the zero contour in either the cin or cape fields will
              ! circumscribe regions of non-zero cape.

              ! In v6.1.0 of ncl, we added a _fillvalue attribute to the return
              ! value of this function. at that time we decided to change -0.1
              ! to a more appropriate missing value, which is passed into this
              ! routine as cmsg.

              ! cape(i,j,kpar) = -0.1d0
              ! cin(i,j,kpar) = -0.1d0
              cape(i,j,kpar) = cmsg
              cin(i,j,kpar)  = cmsg
              klfc = kmax

              GOTO 102

    50        CONTINUE

              !   If there is an equilibrium level, then cape is positive.  we'll
              !   define the level of free convection (lfc) as the point below the
              !   el, but at or above the lcl, where accumulated buoyant energy is a
              !   minimum.  the net positive area (accumulated buoyant energy) from
              !   the lfc up to the el will be defined as the cape, and the net
              !   negative area (negative of accumulated buoyant energy) from the
              !   parcel starting point to the lfc will be defined as the convective
              !   inhibition (cin).

              !   First get the lfc according to the above definition.
              benamin = 9d9
              klfc = kmax
              DO k = klcl,kel
                  IF (benaccum(k) .LT. benamin) THEN
                      benamin = benaccum(k)
                      klfc = k
                  END IF
              END DO

              ! Now we can assign values to cape and cin

              cape(i,j,kpar) = MAX(benaccum(kel)-benamin, 0.1d0)
              cin(i,j,kpar) = MAX(-benamin, 0.1d0)

              ! cin is uninteresting when cape is small (< 100 j/kg), so set
              ! cin to -0.1 (see note about missing values in v6.1.0) in
              ! that case.

              ! In v6.1.0 of ncl, we added a _fillvalue attribute to the return
              ! value of this function. at that time we decided to change -0.1
              ! to a more appropriate missing value, which is passed into this
              ! routine as cmsg.

              ! IF (cape(i,j,kpar).lt.100.d0) cin(i,j,kpar) = -0.1d0
              IF (cape(i,j,kpar) .LT. 100.d0) cin(i,j,kpar) = cmsg
    102   CONTINUE

          END DO

          IF (i3dflag .EQ. 0) THEN
              cape(i,j,mkzh) = cape(i,j,kpar1)
              cin(i,j,mkzh) = cin(i,j,kpar1)
    !  meters agl
              cin(i,j,mkzh-1) = zrel(klcl) + ghtpari - ter(i,j)
    !  meters agl
              cin(i,j,mkzh-2) = zrel(klfc) + ghtpari - ter(i,j)

          ENDIF
      END DO
    END DO

    RETURN
END SUBROUTINE f_computecape


! libRQZ
! author: daan. camps@cs.kuleuven.be
! Description:
!   aggressive early deflation
! ___________________________________________________________________
module d_aed

  use u_activeparts
  use u_parameters
  use d_memorymgmt
  use d_ctransformations
  use d_swappoles12
  use d_swappoles22
  use d_RQZ

  implicit none
  private
  public d_stop_aed, d_start_aed

contains

  subroutine d_start_aed(defl, w, A, B, compAB, apC, apT, Q, compQ, qcol, &
                         Z, compZ, zcol)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Perform aggressive early deflation at the front of the active part with
  ! window length w
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! defl    boolean [OUT]
  !           Deflation indicator
  ! w       integer [IN]
  !           Deflation window size
  ! A       double array [INOUT]
  !           Upper block-Hessenberg matrix A
  ! B       double array [INOUT]
  !           Upper block-Hessenberg matrix B
  ! compAB  boolean [INOUT]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the active parts
  ! apC     type(tAp) [INOUT]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Q       double array [INOUT]
  !           Orthonormal equivalence matrix Q
  ! compQ   boolean [IN]
  !           If true, the left Schur vectors are updated
  ! qcol    integer [IN]
  !           Start index of the columns of Q that are updated:
  !              qcol, qcol+w
  ! Z       double array [INOUT]
  !           Orthonormal equivalence matrix Z
  ! compZ   boolean [IN]
  !           If true, the right Schur vectors are updated
  ! zcol    integer [IN]
  !           Start index of the columns of Z that are updated:
  !              zcol, zcol+w-1
  !___________________________________________________________________________
  ! last edit: January 31, 2019
    real(kind=dp), intent(inout)      ::  A(:,:), B(:,:), Q(:,:), Z(:,:)
    logical, intent(in)               ::  compAB, compQ, compZ
    logical, intent(out)              ::  defl
    integer, intent(in)               ::  w, qcol, zcol
    type(tAp), pointer, intent(inout) ::  apC
    type(tAp), pointer, intent(in)    ::  apT

    real(kind=dp)                     :: amax, ssrc, c, s, r
    integer                           :: i, j, nd, nnd, LDAB, LDQ, LDQW, LDZ, &
                                         LDZW, LDC, LDR, nndth, nnt, wi
    integer,pointer                   :: cstrt, cstp, tstrt, tstp
    type(tAp), pointer                :: apCI, apTI

    external                          :: DGEMM

    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    wi = w
    if (abs(A(cstrt+w+1,cstrt+w-1)) .gt. dzero) then
      wi = wi + 1 ! we take the entire block
    end if

    call tApInit(apCI,cstrt,cstrt+wi)
    call tApInit(apTI,cstrt,cstrt+wi)

    defl = .false.
    call d_getLeadingDim(LDAB,A)
    call d_getLeadingDim(LDQ,Q)
    call d_getLeadingDim(LDQW,QW)
    call d_getLeadingDim(LDZ,Z)
    call d_getLeadingDim(LDZW,ZW)
    call d_getLeadingDim(LDC,Cu)
    call d_getLeadingDim(LDR,Ru)
    nndth = (wi/3) + 1 ! threshold

    QW = dzero
    do i=1, wi
      QW(i,i) = done
    end do

    ZW = dzero
    do i=1, wi
      ZW(i,i) = done
    end do

    ! Deflation logic
    ! Check if block after deflation window is cc or not
    if (abs(A(cstrt+wi+2,cstrt+wi)) .gt. dzero) then
      amax = max(abs(A(cstrt+wi+1,cstrt+wi)),abs(A(cstrt+wi+2,cstrt+wi)))
    else
      amax = abs(A(cstrt+wi+1,cstrt+wi))
    end if

    ! Reduce to Schur form
    call d_RQZ2(A, B, .true., cstrt, cstrt+wi, QW, .true., 1, &
                 ZW, .true., 1, .false.)

    ! Now we'll test eigenvalues in the window for deflations until too
    ! many non deflatables are detected
    nd = 0 ! number of deflations detected
    nnd = 0 ! number of non-deflatables
    nnt = 0 ! number of not tested

    do while ((nd + nnd) .lt. wi-1)
      ! Compute spikes
      Ru(1,1:wi) = ZW(wi,1:wi) * amax ! spike A
      Ru(2,1:wi) = ZW(wi,1:wi) * B(cstrt+wi+1,cstrt+wi) ! spike B

      ! Check if the eigenvalue at the end of the spike is cc or real
      if (abs(A(cstrt+nd+2,cstrt+nd+1)) .gt. dzero ) then
        ! It is cc, so two consecutive elements need to be small
        if ( (abs(Ru(1,nd+1)) + abs(Ru(1,nd+2))) .lt. mp * &
           (abs(A(cstrt+nd+1,cstrt+nd+1)) + abs(A(cstrt+nd+2,cstrt+nd+2))) .and. &
             (abs(Ru(2,nd+1)) + abs(Ru(2,nd+2))) .lt. mp * &
          (abs(B(cstrt+nd+1,cstrt+nd+1)) + abs(B(cstrt+nd+2,cstrt+nd+2)))) then
          ! This one can be deflated
          defl = .true.
          nd = nd + 2
        else
          ! This one cannot be deflated
          nnd = nnd + 2
        end if
      else
        ! It is real so only one element needs to be small
        if ( (abs(Ru(1,nd+1)) .lt. mp * abs(A(cstrt+nd+1,cstrt+nd+1))) .and. &
             (abs(Ru(2,nd+1)) .lt. mp * abs(B(cstrt+nd+1,cstrt+nd+1)))) then
          ! This one can be deflated
          defl = .true.
          nd = nd + 1
       else
         ! This one cannot be deflated
         nnd = nnd + 1
       end if
      end if

      ! Exit if too many tests failed
      if (nnd .gt. nndth) then
        nnt = wi - nd - nnd
        exit
      end if

      if (nd + nnd .lt. wi-1) then
        ! We now move the eigenvalue at position
        ! cstrt + nd + nnd + 1 to position cstrt + nd + 1
        j = cstrt + nd + nnd + 1 ! Index in large matrix
        i = nd + nnd + 1  ! Index in small matrix
        if (abs(A(j+1,j)) .gt. dzero) then
          ! This is a 2x2 block
          do while (i .gt. nd + 1)
            if (i-2 .gt. nd) then
              if (abs(A(j-1,j-2)) .gt. dzero) then
                call d_swap22(j-2, j-2, A, B, .true., apCI, apTI, &
                      QW, .true., i-2, ZW, .true., i-2)
                j = j - 2
                i = i - 2
              else
                call d_swap12(j-1, j-1, A, B, .true., apCI, apTI, &
                      QW, .true., i-1, ZW, .true., i-1)
                j = j - 1
                i = i - 1
              end if
           else
             call d_swap12(j-1, j-1, A, B, .true., apCI, apTI, &
                   QW, .true., i-1, ZW, .true., i-1)
             j = j - 1
             i = i - 1
           end if
          end do
        else
          ! This is a 1x1 block
          do while (i .gt. nd + 1)
            if (i-2 .gt. nd) then
              if (abs(A(j-1,j-2)) .gt. dzero) then
                call d_swap21(j-2, j-2, A, B, .true., apCI, apTI, &
                      QW, .true., i-2, ZW, .true., i-2)
                j = j - 2
                i = i - 2
              else
                call d_swap11(j-1, j-1, A, B, .true., apCI, apTI, &
                      QW, .true., i-1, ZW, .true., i-1)
                j = j - 1
                i = i - 1
              end if
            else
              call d_swap11(j-1, j-1, A, B, .true., apCI, apTI, &
                    QW, .true., i-1, ZW, .true., i-1)
              j = j - 1
              i = i - 1
            end if
          end do
        end if
      end if
    end do

    if (nd + nnd .eq. wi-1) then
      ! Test the last one, which is a single one
      if ( (abs(Ru(1,nd+1)) .lt. mp * abs(A(cstrt+nd+1,cstrt+nd+1))) .and. &
           (abs(Ru(2,nd+1)) .lt. mp * abs(B(cstrt+nd+1,cstrt+nd+1)))) then
        ! This one can be deflated
        defl = .true.
        nd = nd + 1
      else
       ! This one cannot be deflated
       nnd = nnd + 1
      end if
    end if

    ! Restore the block-Hessenberg shape
    if (amax .gt. abs(B(cstrt+wi+1,cstrt+wi))) then
      if (abs(A(cstrt+wi+2,cstrt+wi)) .gt. abs(A(cstrt+wi+1,cstrt+wi))) then
        ssrc = A(cstrt+wi+2,cstrt+wi)
      else
        ssrc = A(cstrt+wi+1,cstrt+wi)
      end if
    else
      ssrc = B(cstrt+wi+1,cstrt+wi)
    endif

    Ru(3,1:wi) = ZW(wi,1:wi) * ssrc
    do j = nd+1, wi-2
      ! Compute the rotation
      call d_compute_ct(Ru(3,j+1),Ru(3,j),c,s,r)
      ! Apply to (A,B)
      call d_apply_ct_r(A(cstrt+1:cstrt+j+2,cstrt+j), &
                        A(cstrt+1:cstrt+j+2,cstrt+j+1),c,s)
      call d_apply_ct_r(B(cstrt+1:cstrt+j+2,cstrt+j), &
                        B(cstrt+1:cstrt+j+2,cstrt+j+1),c,s)
      ! Apply to ZW
      call d_apply_ct_r(ZW(:,j),ZW(:,j+1),c,s)
      Ru(3,j) = dzero
      Ru(3,j+1) = r
    end do

    if (nd+1 .lt. wi) then
      call d_compute_ct(Ru(3,wi),Ru(3,wi-1),c,s,r)
      ! Apply to (A,B)
      call d_apply_ct_r(A(cstrt+1:cstrt+wi,cstrt+wi-1), &
                        A(cstrt+1:cstrt+wi,cstrt+wi),c,s)
      call d_apply_ct_r(B(cstrt+1:cstrt+wi,cstrt+wi-1), &
                        B(cstrt+1:cstrt+wi,cstrt+wi),c,s)
      ! Apply to ZW
      call d_apply_ct_r(ZW(:,wi-1),ZW(:,wi),c,s)

      if (r/ssrc .lt. dzero) then
        A(cstrt+wi+1:cstrt+wi+2,cstrt+wi) = - A(cstrt+wi+1:cstrt+wi+2,cstrt+wi)
        B(cstrt+wi+1,cstrt+wi) = - B(cstrt+wi+1,cstrt+wi)
      end if
    end if

    ! Update the remainder of the pencil
    if (compAB) then
      if (cstrt .gt. 0) then
        ! A column update
        call DGEMM('N','N',cstrt-tstrt,wi,wi,done,A(tstrt+1,cstrt+1),LDAB,&
                  ZW(1,1),LDZW,dzero,Cu(1,1),LDC)
        A(tstrt+1:cstrt,cstrt+1:cstrt+wi) = Cu(1:cstrt-tstrt,1:wi)
        ! B column update
        call DGEMM('N','N',cstrt-tstrt,wi,wi,done,B(tstrt+1,cstrt+1),LDAB,&
                  ZW(1,1),LDZW,dzero,Cu(1,1),LDC)
        B(tstrt+1:cstrt,cstrt+1:cstrt+wi) = Cu(1:cstrt-tstrt,1:wi)
      end if
      ! A row update
      call DGEMM('T','N',wi,tstp-cstrt-wi,wi,done,QW(1,1),LDQW,&
                A(cstrt+1,cstrt+wi+1),LDAB,dzero,Ru(1,1),LDR)
      A(cstrt+1:cstrt+wi,cstrt+wi+1:tstp) = Ru(1:wi,1:tstp-cstrt-wi)
      ! B row update
      call DGEMM('T','N',wi,tstp-cstrt-wi,wi,done,QW(1,1),LDQW,&
                B(cstrt+1,cstrt+wi+1),LDAB,dzero,Ru(1,1),LDR)
      B(cstrt+1:cstrt+wi,cstrt+wi+1:tstp) = Ru(1:wi,1:tstp-cstrt-wi)
    else
      ! A row update
      call DGEMM('T','N',wi,cstp-cstrt-wi,wi,done,QW(1,1),LDQW,&
                A(cstrt+1,cstrt+wi+1),LDAB,dzero,Ru(1,1),LDR)
      A(cstrt+1:cstrt+wi,cstrt+wi+1:cstp) = Ru(1:wi,1:cstp-cstrt-wi)
      ! B row update
      call DGEMM('T','N',wi,cstp-cstrt-wi,wi,done,QW(1,1),LDQW,&
                B(cstrt+1,cstrt+wi+1),LDAB,dzero,Ru(1,1),LDR)
      B(cstrt+1:cstrt+wi,cstrt+wi+1:cstp) = Ru(1:wi,1:cstp-cstrt-wi)
    end if

    if (compQ) then
      call DGEMM('N','N',LDQ,wi,wi,done,Q(1,qcol),LDQ,QW(1,1),LDQW,dzero,Cu,LDC)
      Q(1:LDQ,qcol:qcol+wi-1) = Cu(1:LDQ,1:wi)
    end if

    if (compZ) then
      call DGEMM('N','N',LDZ,wi,wi,done,Z(1,zcol),LDZ,ZW(1,1),LDZW,dzero,Cu,LDC)
      Z(1:LDZ,zcol:zcol+wi-1) = Cu(1:LDZ,1:wi)
    end if

    ! Update indices (also updates it in main)
    call tApPut(apC,strt=cstrt+nd,stp=cstp)

    ! Free everything
    call tApFree(apCI)
    call tApFree(apTI)

  end subroutine

  subroutine d_stop_aed(defl, w, A, B, compAB, apC, apT, Q, compQ, qcol,&
                        Z, compZ, zcol)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Perform aggressive early deflation at the end of the active part with
  ! window length w
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! defl    boolean [OUT]
  !           Deflation indicator
  ! w       integer [IN]
  !           Deflation window size
  ! A       double array [INOUT]
  !           Upper block-Hessenberg matrix A
  ! B       double array [INOUT]
  !           Upper block-Hessenberg matrix B
  ! compAB  boolean [INOUT]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the active parts
  ! apC     type(tAp) [INOUT]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Q       double array [INOUT]
  !           Orthonormal equivalence matrix Q
  ! compQ   boolean [IN]
  !           If true, the left Schur vectors are updated
  ! qcol    integer [IN]
  !           Start index of the columns of Q that are updated:
  !              qcol, qcol+1, ...,qcol+w-1
  ! Z       double array [INOUT]
  !           Orthonormal equivalence matrix Z
  ! compZ   boolean [IN]
  !           If true, the right Schur vectors are updated
  ! zcol    integer [IN]
  !           Start index of the columns of Z that are updated:
  !              zcol, zcol+1, ..., zcol+w-1
  !___________________________________________________________________________
  ! last edit: January 31, 2019
    real(kind=dp), intent(inout)      ::  A(:,:), B(:,:), Q(:,:), Z(:,:)
    logical, intent(in)               ::  compAB, compQ, compZ
    logical, intent(out)              ::  defl
    integer, intent(in)               ::  w, qcol, zcol
    type(tAp), pointer, intent(inout) ::  apC
    type(tAp), pointer, intent(in)    ::  apT

    real(kind=dp)                     :: amax, c, s, r, ssrc
    integer                           :: i, j, nd, nnd, LDAB, LDQ, LDQW, &
                                         LDZ, LDZW, LDC, LDR, nndth, nnt, wi,&
                                         qci,zci
    integer,pointer                   :: cstrt, cstp, tstrt, tstp
    type(tAp), pointer                :: apCI, apTI

    external                          :: DGEMM

    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)
    wi = w
    qci = qcol
    zci = zcol

    if (abs(A(cstp-w+2,cstp-w)) .gt. dzero) then
      wi = wi + 1 ! we take the entire block
      qci = qci - 1
      zci = zci - 1
    end if

    call tApInit(apCI,cstp-wi,cstp)
    call tApInit(apTI,cstp-wi,cstp)

    defl = .false.
    call d_getLeadingDim(LDAB,A)
    call d_getLeadingDim(LDQ,Q)
    call d_getLeadingDim(LDQW,QW)
    call d_getLeadingDim(LDZ,Z)
    call d_getLeadingDim(LDZW,ZW)
    call d_getLeadingDim(LDC,Cu)
    call d_getLeadingDim(LDR,Ru)
    nndth = (wi/3) + 1 ! threshold

    QW = dzero
    do i=1, wi
      QW(i,i) = done
    end do

    ZW = dzero
    do i=1, wi
      ZW(i,i) = done
    end do

    ! Deflation logic
    ! Check if block before deflation window is cc pole or not
    if (abs(A(cstp-wi+1,cstp-wi-1)) .gt. dzero) then
      amax = max(abs(A(cstp-wi+1,cstp-wi-1)),abs(A(cstp-wi+1,cstp-wi)))
    else
      amax = abs(A(cstp-wi+1,cstp-wi))
    end if

    ! Reduce to Schur form
    call d_RQZ2(A, B, .true., cstp-wi, cstp, QW, .true., 1, &
                 ZW, .true., 1, .false.)

    ! Now we'll test eigenvalues in the window for deflations until too
    ! many non deflatables are detected
    nd = 0 ! number of deflations detected
    nnd = 0 ! number of non-deflatables
    nnt = 0 ! number of not tested

    do while ((nd + nnd) .lt. wi-1)
      ! Compute spikes and store then in Ru array
      Ru(1:wi,1) = QW(1,1:wi) * amax ! spike A
      Ru(1:wi,2) = QW(1,1:wi) * B(cstp-wi+1,cstp-wi) ! spike B

      ! Check if the eigenvalue at the end of the spike is cc or real
      if (abs(A(cstp-nd,cstp-nd-1)) .gt. dzero) then
        ! It is cc, so two consecutive elements need to be small
        if( (abs(Ru(wi-nd,1)) + abs(Ru(wi-nd-1,1))) .lt. mp * &
              (abs(A(cstp-nd,cstp-nd)) + abs(A(cstp-nd-1,cstp-nd-1))) .and. &
              (abs(Ru(wi-nd,2)) + abs(Ru(wi-nd-1,2))) .lt. mp * &
              (abs(B(cstp-nd,cstp-nd)) + abs(B(cstp-nd-1,cstp-nd-1)))) then
          ! This one can be deflated
          defl = .true.
          nd = nd + 2
        else
          ! This one cannot be deflated
          nnd = nnd + 2
        end if
      else
        ! It is real, so only one element needs to be small
        if ( (abs(Ru(wi-nd,1)) .lt. mp * abs(A(cstp-nd,cstp-nd))) .and. &
           (abs(Ru(wi-nd,2)) .lt. mp * abs(B(cstp-nd,cstp-nd))) ) then
          ! This one can be deflated
          defl = .true.
          nd = nd + 1
       else
         ! This one cannot be deflated
         nnd = nnd + 1
       end if
      end if

      ! Exit if too many deflation tests failed
      if (nnd .gt. nndth) then
        nnt = wi - nd - nnd
        exit
      end if

      if (nd + nnd .lt. wi-1) then
        ! We now move the eigenvalue at position
        ! cstp-nd-nnd to position cstp-nd
        j = cstp-nd-nnd ! Index in large matrix
        i = wi-nd-nnd ! Index in small matrix
        if (abs(A(j,j-1)) .gt. dzero) then
          ! This is a 2x2 block
          j = j - 1
          i = i - 1
          do while (i .lt. wi-nd-1)

            if (i+2 .lt. wi-nd) then
              if (abs(A(j+3,j+2)) .gt. dzero) then
                call d_swap22(j, j, A, B, .true., apCI, apTI, &
                      QW, .true., i, ZW, .true., i)
                j = j + 2
                i = i + 2
              else
                call d_swap21(j, j, A, B, .true., apCI, apTI, &
                       QW, .true., i, ZW, .true., i)
                j = j + 1
                i = i + 1
              end if
            else
              call d_swap21(j, j, A, B, .true., apCI, apTI, &
                     QW, .true., i, ZW, .true., i)
              j = j + 1
              i = i + 1
            end if
          end do
        else
          ! This is a 1x1 block
          do while (i .lt. wi-nd)
            if (i+1 .lt. wi-nd) then
              if (abs(A(j+2,j+1)) .gt. dzero) then
                call d_swap12(j, j, A, B, .true., apCI, apTI, &
                      QW, .true., i, ZW, .true., i)
                j = j + 2
                i = i + 2
              else
                call d_swap11(j, j, A, B, .true., apCI, apTI, &
                      QW, .true., i, ZW, .true., i)
                j = j + 1
                i = i + 1
              end if
            else
              call d_swap11(j, j, A, B, .true., apCI, apTI, &
                    QW, .true., i, ZW, .true., i)
              j = j + 1
              i = i + 1
            end if
          end do
        end if
      end if
    end do

    if (nd + nnd .eq. wi-1) then
      ! test the last one, which is a single one
      if ( (abs(Ru(wi-nd,1)) .lt. mp * abs(A(cstp-nd,cstp-nd))) .and. &
         (abs(Ru(wi-nd,2)) .lt. mp * abs(B(cstp-nd,cstp-nd))) ) then
        ! This one can be deflated
        defl = .true.
        nd = nd + 1
     else
       ! This one cannot be deflated
       nnd = nnd + 1
     end if
    end if

    ! Restore the (block)-Hessenberg shape
    if (amax .gt. abs(B(cstp-wi+1,cstp-wi))) then
      if (abs(A(cstp-wi+1,cstp-wi)) .gt. abs(A(cstp-wi+1,cstp-wi-1))) then
        ssrc = A(cstp-wi+1,cstp-wi)
      else
        ssrc = A(cstp-wi+1,cstp-wi-1)
      end if
    else
      ssrc = B(cstp-wi+1,cstp-wi)
    end if

    Ru(1:wi,3) = QW(1,1:wi) * ssrc
    do j = wi-nd-1,2,-1
      ! Compute the rotation
      call d_compute_ct(Ru(j,3),Ru(j+1,3),c,s,r)
      ! Apply to (A,B)
      call d_apply_ct_l(A(cstp+j-wi,cstp+j-wi-1:cstp), &
                        A(cstp+j-wi+1,cstp+j-wi-1:cstp),c,s)
      call d_apply_ct_l(B(cstp+j-wi,cstp+j-wi:cstp), &
                        B(cstp+j-wi+1,cstp+j-wi:cstp),c,s)
      ! Appl to QW
      call d_apply_ct_r(QW(1:wi+1,j),QW(1:wi+1,j+1),c,-s)
      Ru(j,3) = r
      Ru(j+1,3) = dzero
    end do

    if (wi-nd-1 .gt. 0) then
      call d_compute_ct(Ru(1,3),Ru(2,3),c,s,r)

      ! Apply to (A,B)
      call d_apply_ct_l(A(cstp-wi+1,cstp-wi+1:cstp), &
                      A(cstp-wi+2,cstp-wi+1:cstp),c,s)
      call d_apply_ct_l(B(cstp-wi+1,cstp-wi+1:cstp), &
                      B(cstp-wi+2,cstp-wi+1:cstp),c,s)
      ! Apply to QW
      call d_apply_ct_r(QW(1:wi+1,1),QW(1:wi+1,2),c,-s)

      if (r/ssrc .lt. dzero) then
        A(cstp-wi+1,cstp-wi-1:cstp-wi) = -A(cstp-wi+1,cstp-wi-1:cstp-wi)
        B(cstp-wi+1,cstp-wi) = -B(cstp-wi+1,cstp-wi)
      end if
    end if

    ! Update the remainder of the pencil
    if (compAB) then
      ! A column update
      call DGEMM('N','N',cstp-wi-tstrt,wi,wi,done,A(tstrt+1,cstp-wi+1),LDAB,&
                 ZW(1,1),LDZW,dzero,Cu(1,1),LDC)
      A(tstrt+1:cstp-wi,cstp-wi+1:cstp) = Cu(1:cstp-wi-tstrt,1:wi)
      ! B column update
      call DGEMM('N','N',cstp-wi-tstrt,wi,wi,done,B(tstrt+1,cstp-wi+1),LDAB,&
                 ZW(1,1),LDZW,dzero,Cu(1,1),LDC)
      B(tstrt+1:cstp-wi,cstp-wi+1:cstp) = Cu(1:cstp-wi-tstrt,1:wi)
      if (cstp .lt. tstp) then
        ! A row update
        call DGEMM('T','N',wi,tstp-cstp,wi,done,QW(1,1),LDQW,&
                   A(cstp-wi+1,cstp+1),LDAB,dzero,Ru(1,1),LDR)
        A(cstp-wi+1:cstp,cstp+1:tstp) = Ru(1:wi,1:tstp-cstp)
        ! B row update
        call DGEMM('T','N',wi,tstp-cstp,wi,done,QW(1,1),LDQW,&
                   B(cstp-wi+1,cstp+1),LDAB,dzero,Ru(1,1),LDR)
        B(cstp-wi+1:cstp,cstp+1:tstp) = Ru(1:wi,1:tstp-cstp)
      end if
    else
      ! A column update
      call DGEMM('N','N',cstp-wi-cstrt,wi,wi,done,A(cstrt+1,cstp-wi+1),&
                LDAB,ZW(1,1),LDZW,dzero,Cu(1,1),LDC)
      A(cstrt+1:cstp-wi,cstp-wi+1:cstp) = Cu(1:cstp-wi-cstrt,1:wi)
      ! B column update
      call DGEMM('N','N',cstp-wi-cstrt,wi,wi,done,A(cstrt+1,cstp-wi+1),&
                LDAB,ZW(1,1),LDZW,dzero,Cu(1,1),LDC)
      A(cstrt+1:cstp-wi,cstp-wi+1:cstp) = Cu(1:cstp-wi-cstrt,1:wi)
    end if

    if (compQ) then
      call DGEMM('N','N',LDQ,wi,wi,done,Q(1,qci),LDQ,QW(1,1),LDQW,dzero,Cu,LDC)
      Q(1:LDQ,qci:qci+wi-1) = Cu(1:LDQ,1:wi)
    end if

    if (compZ) then
      call DGEMM('N','N',LDZ,wi,wi,done,Z(1,zci),LDZ,&
                ZW(1,1),LDZW,dzero,Cu,LDC)
      Z(1:LDZ,zci:zci+wi-1) = Cu(1:LDZ,1:wi)
    end if

    ! Update indices (also updates it in main)
    call tApPut(apC,strt=cstrt,stp=cstp-nd)

    ! Free everything
    call tApFree(apCI)
    call tApFree(apTI)

  end subroutine
end module


! { dg-do run }
! PR36420 Fortran 2008: g0 edit descriptor
! Test case provided by Jerry DeLisle <jvdelisle@gcc.gnu.org>
    character(25) :: string = "(g0,g0,g0)"
    character(50) :: buffer
    write(buffer, '(g0,g0,g0)') ':',12340,':'
    if (buffer.ne.":12340:") call abort
    write(buffer, string) ':',0,':'
    if (buffer.ne.":0:") call abort
    write(buffer, string) ':',1.0_8/3.0_8,':'
    if (buffer.ne.":0.33333333333333331:") call abort
    write(buffer, '(1x,a,g0,a)') ':',1.0_8/3.0_8,':'
    if (buffer.ne." :0.33333333333333331:") call abort
    write(buffer, string) ':',"hello",':'
    if (buffer.ne.":hello:") call abort
    write(buffer, "(g0,g0,g0,g0)") ':',.true.,.false.,':'
    if (buffer.ne.":TF:") call abort
    write(buffer, "(g0,g0,',',g0,g0)") '(',( 1.2345_8, 2.4567_8 ),')'
    if (buffer.ne."(1.2344999999999999,2.4567000000000001)") call abort
end


program i
  integer ::b
  integer ::a
  integer ::c
  integer, dimension(5) :: array
  a = 3
  b = 20
  array(1) = 1
  array(2) = 2
  array(3) = 3
  array(4) = array(1) + array(2) * array(3)
  array(5) = a + b
  c = array(1) + array(2) + array(3) + array(4)

end program i