*DECK DCDOT
      SUBROUTINE DCDOT (N, FM, CX, INCX, CY, INCY, DCR, DCI)
C***BEGIN PROLOGUE  DCDOT
C***PURPOSE  Compute the inner product of two vectors with extended
C            precision accumulation and result.
C***LIBRARY   SLATEC (BLAS)
C***CATEGORY  D1A4
C***TYPE      COMPLEX (DSDOT-D, DCDOT-C)
C***KEYWORDS  BLAS, COMPLEX VECTORS, DOT PRODUCT, INNER PRODUCT,
C             LINEAR ALGEBRA, VECTOR
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C    Compute the dot product of 2 complex vectors, CX and CY, e.g.
C    CX DOT CY, or, CXconjugate DOT CY.  The real and imaginary
C    parts of CX and CY are converted to double precision, the dot
C    product accumulation is done in double precision and the output
C    is given as 2 double precision numbers, corresponding to the real
C    and imaginary part of the result.
C     Input
C      N:  Number of complex components of CX and CY.
C      FM: =+1.0   compute CX DOT CY.
C          =-1.0   compute CXconjugate DOT CY.
C      CX(N):
C      CY(N):  Complex arrays of length N.
C      INCX:(Integer)   Spacing of elements of CX to use
C      INCY:(Integer)   Spacing of elements of CY to use.
C     Output
C      DCR:(Double Precision) Real part of dot product.
C      DCI:(Double Precision) Imaginary part of dot product.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   790101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  DCDOT
      INTEGER I, INCX, INCY, KX, KY, N
      COMPLEX CX(*), CY(*)
      DOUBLE PRECISION DCR, DCI, DT1, DT2, DT3, DT4, FM
C***FIRST EXECUTABLE STATEMENT  DCDOT
      DCR = 0.0D0
      DCI = 0.0D0
      IF (N .LE. 0) GO TO 20
C
      KX = 1
      KY = 1
      IF (INCX .LT. 0) KX = 1+(1-N)*INCX
      IF (INCY .LT. 0) KY = 1+(1-N)*INCY
      DO 10 I = 1,N
        DT1 = DBLE(REAL(CX(KX)))
        DT2 = DBLE(REAL(CY(KY)))
        DT3 = DBLE(AIMAG(CX(KX)))
        DT4 = DBLE(AIMAG(CY(KY)))
        DCR = DCR+(DT1*DT2)-FM*(DT3*DT4)
        DCI = DCI+(DT1*DT4)+FM*(DT3*DT2)
        KX = KX+INCX
        KY = KY+INCY
   10 CONTINUE
   20 RETURN
      END


      SUBROUTINE SB02MT( JOBG, JOBL, FACT, UPLO, N, M, A, LDA, B, LDB,
     $                   Q, LDQ, R, LDR, L, LDL, IPIV, OUFACT, G, LDG,
     $                   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 compute the following matrices
C
C                -1
C         G = B*R  *B',
C
C         -          -1
C         A = A - B*R  *L',
C
C         -          -1
C         Q = Q - L*R  *L',
C
C     where A, B, Q, R, L, and G are N-by-N, N-by-M, N-by-N, M-by-M,
C     N-by-M, and N-by-N matrices, respectively, with Q, R and G
C     symmetric matrices.
C
C     When R is well-conditioned with respect to inversion, standard
C     algorithms for solving linear-quadratic optimization problems will
C     then also solve optimization problems with coupling weighting
C     matrix L. Moreover, a gain in efficiency is possible using matrix
C     G in the deflating subspace algorithms (see SLICOT Library routine
C     SB02OD).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOBG    CHARACTER*1
C             Specifies whether or not the matrix G is to be computed,
C             as follows:
C             = 'G':  Compute G;
C             = 'N':  Do not compute G.
C
C     JOBL    CHARACTER*1
C             Specifies whether or not the matrix L is zero, as follows:
C             = 'Z':  L is zero;
C             = 'N':  L is nonzero.
C
C     FACT    CHARACTER*1
C             Specifies how the matrix R is given (factored or not), as
C             follows:
C             = 'N':  Array R contains the matrix R;
C             = 'C':  Array R contains the Cholesky factor of R;
C             = 'U':  Array R contains the symmetric indefinite UdU' or
C                     LdL' factorization of R.
C
C     UPLO    CHARACTER*1
C             Specifies which triangle of the matrices R and Q (if
C             JOBL = 'N') is stored, as follows:
C             = 'U':  Upper triangle is stored;
C             = 'L':  Lower triangle is stored.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, Q, and G, and the number of
C             rows of the matrices B and L.  N >= 0.
C
C     M       (input) INTEGER
C             The order of the matrix R, and the number of columns of
C             the matrices B and L.  M >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, if JOBL = 'N', the leading N-by-N part of this
C             array must contain the matrix A.
C             On exit, if JOBL = 'N', and INFO = 0, the leading N-by-N
C                                                    -          -1
C             part of this array contains the matrix A = A - B*R  L'.
C             If JOBL = 'Z', this array is not referenced.
C
C     LDA     INTEGER
C             The leading dimension of array A.
C             LDA >= MAX(1,N) if JOBL = 'N';
C             LDA >= 1        if JOBL = 'Z'.
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the matrix B.
C             On exit, if OUFACT = 1, and INFO = 0, the leading N-by-M
C                                                             -1
C             part of this array contains the matrix B*chol(R)  .
C             On exit, B is unchanged if OUFACT = 2 (hence also when
C             FACT = 'U').
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
C             On entry, if JOBL = 'N', the leading N-by-N upper
C             triangular part (if UPLO = 'U') or lower triangular part
C             (if UPLO = 'L') of this array must contain the upper
C             triangular part or lower triangular part, respectively, of
C             the symmetric matrix Q. The stricly lower triangular part
C             (if UPLO = 'U') or stricly upper triangular part (if
C             UPLO = 'L') is not referenced.
C             On exit, if JOBL = 'N' and INFO = 0, the leading N-by-N
C             upper triangular part (if UPLO = 'U') or lower triangular
C             part (if UPLO = 'L') of this array contains the upper
C             triangular part or lower triangular part, respectively, of
C                                  -          -1
C             the symmetric matrix Q = Q - L*R  *L'.
C             If JOBL = 'Z', this array is not referenced.
C
C     LDQ     INTEGER
C             The leading dimension of array Q.
C             LDQ >= MAX(1,N) if JOBL = 'N';
C             LDQ >= 1        if JOBL = 'Z'.
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,M)
C             On entry, if FACT = 'N', the leading M-by-M upper
C             triangular part (if UPLO = 'U') or lower triangular part
C             (if UPLO = 'L') of this array must contain the upper
C             triangular part or lower triangular part, respectively,
C             of the symmetric input weighting matrix R.
C             On entry, if FACT = 'C', the leading M-by-M upper
C             triangular part (if UPLO = 'U') or lower triangular part
C             (if UPLO = 'L') of this array must contain the Cholesky
C             factor of the positive definite input weighting matrix R
C             (as produced by LAPACK routine DPOTRF).
C             On entry, if FACT = 'U', the leading M-by-M upper
C             triangular part (if UPLO = 'U') or lower triangular part
C             (if UPLO = 'L') of this array must contain the factors of
C             the UdU' or LdL' factorization, respectively, of the
C             symmetric indefinite input weighting matrix R (as produced
C             by LAPACK routine DSYTRF).
C             If FACT = 'N', the stricly lower triangular part (if UPLO
C             = 'U') or stricly upper triangular part (if UPLO = 'L') of
C             this array is used as workspace.
C             On exit, if OUFACT = 1, and INFO = 0 (or INFO = M+1),
C             the leading M-by-M upper triangular part (if UPLO = 'U')
C             or lower triangular part (if UPLO = 'L') of this array
C             contains the Cholesky factor of the given input weighting
C             matrix.
C             On exit, if OUFACT = 2, and INFO = 0 (or INFO = M+1),
C             the leading M-by-M upper triangular part (if UPLO = 'U')
C             or lower triangular part (if UPLO = 'L') of this array
C             contains the factors of the UdU' or LdL' factorization,
C             respectively, of the given input weighting matrix.
C             On exit R is unchanged if FACT = 'C' or 'U'.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,M).
C
C     L       (input/output) DOUBLE PRECISION array, dimension (LDL,M)
C             On entry, if JOBL = 'N', the leading N-by-M part of this
C             array must contain the matrix L.
C             On exit, if JOBL = 'N', OUFACT = 1, and INFO = 0, the
C             leading N-by-M part of this array contains the matrix
C                      -1
C             L*chol(R)  .
C             On exit, L is unchanged if OUFACT = 2 (hence also when
C             FACT = 'U').
C             L is not referenced if JOBL = 'Z'.
C
C     LDL     INTEGER
C             The leading dimension of array L.
C             LDL >= MAX(1,N) if JOBL = 'N';
C             LDL >= 1        if JOBL = 'Z'.
C
C     IPIV    (input/output) INTEGER array, dimension (M)
C             On entry, if FACT = 'U', this array must contain details
C             of the interchanges performed and the block structure of
C             the d factor in the UdU' or LdL' factorization of matrix R
C             (as produced by LAPACK routine DSYTRF).
C             On exit, if OUFACT = 2, this array contains details of
C             the interchanges performed and the block structure of the
C             d factor in the UdU' or LdL' factorization of matrix R,
C             as produced by LAPACK routine DSYTRF.
C             This array is not referenced if FACT = 'C'.
C
C     OUFACT  (output) INTEGER
C             Information about the factorization finally used.
C             OUFACT = 1:  Cholesky factorization of R has been used;
C             OUFACT = 2:  UdU' (if UPLO = 'U') or LdL' (if UPLO = 'L')
C                          factorization of R has been used.
C
C     G       (output) DOUBLE PRECISION array, dimension (LDG,N)
C             If JOBG = 'G', and INFO = 0, the leading N-by-N upper
C             triangular part (if UPLO = 'U') or lower triangular part
C             (if UPLO = 'L') of this array contains the upper
C             triangular part (if UPLO = 'U') or lower triangular part
C                                                                 -1
C             (if UPLO = 'L'), respectively, of the matrix G = B*R  B'.
C             If JOBG = 'N', this array is not referenced.
C
C     LDG     INTEGER
C             The leading dimension of array G.
C             LDG >= MAX(1,N) if JOBG = 'G',
C             LDG >= 1        if JOBG = 'N'.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (M)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK; if FACT = 'N', DWORK(2) contains the reciprocal
C             condition number of the given matrix R.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 1              if FACT = 'C';
C             LDWORK >= MAX(2,3*M,N*M) if FACT = 'N';
C             LDWORK >= MAX(1,N*M)     if FACT = 'U'.
C             For optimum performance LDWORK should be larger than 3*M,
C             if FACT = 'N'.
C             The N*M workspace is not needed for FACT = 'N', if matrix
C             R is positive definite.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = i:  if the i-th element (1 <= i <= M) of the d factor is
C                   exactly zero; the UdU' (or LdL') factorization has
C                   been completed, but the block diagonal matrix d is
C                   exactly singular;
C             = M+1:  if the matrix R is numerically singular.
C
C     METHOD
C                            -     -
C     The matrices G, and/or A and Q are evaluated using the given or
C     computed symmetric factorization of R.
C
C     NUMERICAL ASPECTS
C
C     The routine should not be used when R is ill-conditioned.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Algebraic Riccati equation, closed loop system, continuous-time
C     system, discrete-time system, optimal regulator, Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         FACT, JOBG, JOBL, UPLO
      INTEGER           INFO, LDA, LDB, LDG, LDL, LDQ, LDR, LDWORK, M,
     $                  N, OUFACT
C     .. Array Arguments ..
      INTEGER           IPIV(*), IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), DWORK(*), G(LDG,*),
     $                  L(LDL,*), Q(LDQ,*), R(LDR,*)
C     .. Local Scalars ..
      LOGICAL           LFACTA, LFACTC, LFACTU, LJOBG, LJOBL, LUPLOU
      CHARACTER         TRANS
      INTEGER           I, J, WRKOPT
      DOUBLE PRECISION  EPS, RCOND, RNORM
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANSY
      EXTERNAL          DLAMCH, DLANSY, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMM, DGEMV, DPOCON, DPOTRF, DSYCON,
     $                  DSYRK, DSYTRF, DSYTRS, DTRSM, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX
C     .. Executable Statements ..
C
      INFO   = 0
      LJOBG  = LSAME( JOBG, 'G' )
      LJOBL  = LSAME( JOBL, 'N' )
      LFACTC = LSAME( FACT, 'C' )
      LFACTU = LSAME( FACT, 'U' )
      LUPLOU = LSAME( UPLO, 'U' )
      LFACTA = LFACTC.OR.LFACTU
C
C     Test the input scalar arguments.
C
      IF( .NOT.LJOBG .AND. .NOT.LSAME( JOBG, 'N' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LJOBL .AND. .NOT.LSAME( JOBL, 'Z' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.LFACTA .AND. .NOT.LSAME( FACT, 'N' ) ) THEN
         INFO = -3
      ELSE IF( .NOT.LUPLOU .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( M.LT.0 ) THEN
         INFO = -6
      ELSE IF( ( LDA.LT.1 ) .OR. ( LJOBL .AND. LDA.LT.N ) ) THEN
         INFO = -8
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( ( LDQ.LT.1 ) .OR. ( LJOBL .AND. LDQ.LT.N ) ) THEN
         INFO = -12
      ELSE IF( LDR.LT.MAX( 1, M ) ) THEN
         INFO = -14
      ELSE IF( ( LDL.LT.1 ) .OR. ( LJOBL .AND. LDL.LT.N ) ) THEN
         INFO = -16
      ELSE IF( ( LDG.LT.1 ) .OR. ( LJOBG .AND. LDG.LT.N ) ) THEN
         INFO = -20
      ELSE IF( ( LFACTC .AND. LDWORK.LT.1 ) .OR.
     $         ( LFACTU .AND. LDWORK.LT.MAX( 1, N*M ) ) .OR.
     $    ( .NOT.LFACTA .AND. LDWORK.LT.MAX( 2, N*M, 3*M ) ) ) THEN
         INFO = -23
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB02MT', -INFO )
         RETURN
      END IF
C
      IF ( LFACTC ) THEN
         OUFACT = 1
      ELSE IF ( LFACTU ) THEN
         OUFACT = 2
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 .OR. M.EQ.0 .OR. .NOT.( LJOBL.OR.LJOBG ) ) THEN
        DWORK(1) = ONE
        IF ( .NOT.LFACTA ) DWORK(2) = ONE
        RETURN
      END IF
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of workspace needed at that point in the code,
C     as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      WRKOPT = 1
C
C     Set relative machine precision.
C
      EPS = DLAMCH( 'Epsilon' )
C
      IF ( .NOT.LFACTA ) THEN
C
C        Compute the norm of the matrix R, which is not factored.
C        Then save the given triangle of R in the other strict triangle
C        and the diagonal in the workspace, and try Cholesky
C        factorization.
C        Workspace: need M.
C
         RNORM = DLANSY( '1-norm', UPLO, M, R, LDR, DWORK )
         CALL DCOPY( M, R, LDR+1, DWORK, 1 )
         IF( LUPLOU ) THEN
C
            DO 20 J = 2, M
               CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR )
   20       CONTINUE
C
         ELSE
C
            DO 40 J = 2, M
               CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 )
   40       CONTINUE
C
         END IF
         CALL DPOTRF( UPLO, M, R, LDR, INFO )
         IF( INFO.EQ.0 ) THEN
C
C           Compute the reciprocal of the condition number of R.
C           Workspace: need 3*M.
C
            CALL DPOCON( UPLO, M, R, LDR, RNORM, RCOND, DWORK, IWORK,
     $                   INFO )
C
C           Return if the matrix is singular to working precision.
C
            OUFACT = 1
            DWORK(2) = RCOND
            IF( RCOND.LT.EPS ) THEN
               INFO = M + 1
               RETURN
            END IF
            WRKOPT = MAX( WRKOPT, 3*M )
         ELSE
C
C           Use UdU' or LdL' factorization, first restoring the saved
C           triangle.
C
            CALL DCOPY( M, DWORK, 1, R, LDR+1 )
            IF( LUPLOU ) THEN
C
               DO 60 J = 2, M
                  CALL DCOPY( J-1, R(J,1), LDR, R(1,J), 1 )
   60          CONTINUE
C
            ELSE
C
               DO 80 J = 2, M
                  CALL DCOPY( J-1, R(1,J), 1, R(J,1), LDR )
   80          CONTINUE
C
            END IF
C
C           Compute the UdU' or LdL' factorization.
C           Workspace: need   1,
C                      prefer M*NB.
C
            CALL DSYTRF( UPLO, M, R, LDR, IPIV, DWORK, LDWORK, INFO )
            OUFACT = 2
            IF( INFO.GT.0 ) THEN
               DWORK(2) = ONE
               RETURN
            END IF
            WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
C
C           Compute the reciprocal of the condition number of R.
C           Workspace: need 2*M.
C
            CALL DSYCON( UPLO, M, R, LDR, IPIV, RNORM, RCOND, DWORK,
     $                   IWORK, INFO )
C
C           Return if the matrix is singular to working precision.
C
            DWORK(2) = RCOND
            IF( RCOND.LT.EPS ) THEN
               INFO = M + 1
               RETURN
            END IF
         END IF
      END IF
C
      IF (OUFACT.EQ.1 ) THEN
C
C        Solve positive definite linear system(s).
C
         IF ( LUPLOU ) THEN
            TRANS = 'N'
         ELSE
            TRANS = 'T'
         END IF
C
C        Solve the system X*U = B, overwriting B with X.
C
         CALL DTRSM( 'Right', UPLO, TRANS, 'Non-unit', N, M,
     $               ONE, R, LDR, B, LDB )
C
         IF ( LJOBG ) THEN
C                                      -1
C           Compute the matrix  G = B*R  *B', multiplying X*X' in G.
C
            CALL DSYRK( UPLO, 'No transpose', N, M, ONE, B, LDB, ZERO,
     $                  G, LDG )
         END IF
C
         IF( LJOBL ) THEN
C
C           Update matrices A and Q.
C
C           Solve the system Y*U = L, overwriting L with Y.
C
            CALL DTRSM( 'Right', UPLO, TRANS, 'Non-unit', N, M,
     $                  ONE, R, LDR, L, LDL )
C
C           Compute A <- A - X*Y'.
C
            CALL DGEMM( 'No transpose', 'Transpose', N, N, M, -ONE, B,
     $                  LDB, L, LDL, ONE, A, LDA )
C
C           Compute Q <- Q - Y*Y'.
C
            CALL DSYRK( UPLO, 'No transpose', N, M, -ONE, L, LDL, ONE,
     $                  Q, LDQ )
         END IF
      ELSE
C
C        Solve indefinite linear system(s).
C
C        Solve the system UdU'*X = B' (or LdL'*X = B').
C        Workspace: need N*M.
C
         DO 100 J = 1, M
            CALL DCOPY( N, B(1,J), 1, DWORK(J), M )
  100    CONTINUE
C
         CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, DWORK, M, INFO )
C
         IF ( LJOBG ) THEN
C                                                    -1
C           Compute a triangle of the matrix  G = B*R  *B' = B*X.
C
            IF ( LUPLOU ) THEN
               I = 1
C
               DO 120 J = 1, N
                  CALL DGEMV( 'No transpose', J, M, ONE, B, LDB,
     $                        DWORK(I), 1, ZERO, G(1,J), 1 )
                  I = I + M
  120          CONTINUE
C
            ELSE
C
               DO 140 J = 1, N
                  CALL DGEMV( 'Transpose', M, J, ONE, DWORK, M, B(J,1),
     $                        LDB, ZERO, G(J,1), LDG )
  140          CONTINUE
C
            END IF
         END IF
C
         IF( LJOBL ) THEN
C
C           Update matrices A and Q.
C
C           Solve the system UdU'*Y = L' (or LdL'*Y = L').
C
            DO 160 J = 1, M
               CALL DCOPY( N, L(1,J), 1, DWORK(J), M )
  160       CONTINUE
C
            CALL DSYTRS( UPLO, M, N, R, LDR, IPIV, DWORK, M, INFO )
C
C           A <- A - B*Y.
C
            CALL DGEMM( 'No transpose', 'No transpose', N, N, M, -ONE,
     $                  B, LDB, DWORK, M, ONE, A, LDA )
C                                            -          -1
C           Compute a triangle of the matrix Q = Q - L*R  *L' = Q - L*Y.
C
            IF ( LUPLOU ) THEN
               I = 1
C
               DO 180 J = 1, N
                  CALL DGEMV( 'No transpose', J, M, -ONE, L, LDL,
     $                        DWORK(I), 1, ONE, Q(1,J), 1 )
                  I = I + M
  180          CONTINUE
C
            ELSE
C
               DO 200 J = 1, N
                  CALL DGEMV( 'Transpose', M, J, -ONE, DWORK, M, L(J,1),
     $                        LDL, ONE, Q(J,1), LDQ )
  200          CONTINUE
C
            END IF
         END IF
      END IF
C
      DWORK(1) = WRKOPT
      IF ( .NOT.LFACTA ) DWORK(2) = RCOND
C
C *** Last line of SB02MT ***
      RETURN
      END


      SUBROUTINE C3FFT(C,ID,NL,NM,NN,WL,WM,WN,IOPT,ISIG,IORD,IWORK,IERR)
****PURPOSE:
*       THIS ROUTINE PERFORMS A 3-DIMENSIONAL COMPLEX FOURIER TRANSFORM,
*       OF ORDER NL*NM*NN  .
*       IT IS A USER INTERFACE FOR A PACKAGE (MFFT), SPECIALLY DESIGNED
*       FOR HIGH PERFORMANCE ON CRAY X-MP MACHINES.
****USAGE:
*       THE USER IS EXPECTED TO PROVIDE THE DATA IN A 3-DIMENSIONAL
*       COMPLEX ARRAY C, DIMENSIONED IN THE CALLING PROGRAM C(ID,NM,NN);
*       ID CAN BE DIFFERENT FROM NL, AND IT IS RECOMMENDED THAT IT IS
*       CHOSEN ODD FOR MAXIMUM PERFORMANCE. THE ROUTINE IS
*       INTENDED FOR REPEATED USAGE, THUS SEPARATE SET-UP AND
*       OPERATING CALLS ARE AVAILABLE : THE USER SHOULD ALWAYS PERFORM
*       A SET-UP CALL ( ISIG=0 ) PASSING THE CHOSEN PARAMETERS, BEFORE
*       PERFORMING THE ACTUAL TRANSFORM ( ISIG= +1 OR -1 ); THE USER CAN
*       CHOOSE WHETHER TO OBTAIN THE RESULTS OF THE DIRECT TRANSFORM
*       IN NATURAL ORDER (ISIG=-1,IORD=1) OR LEAVE THEM IN THE
*       BIT-REVERSED  ORDER( ISIG=-1,IORD=0); THIS CHOICE SAVES
*       SOME COMPUTER TIME, AND IT IS RECOMMENDED IN CASES DISCUSSED
*       IN THE LONG WRITE-UP. ANALOGOUSLY, THE INVERSE TRANSFORM ACCEPTS
*       INPUT ( PLEASE NOTE| ) DATA IN NATURAL ORDER ( ISIG=1,IORD=1),
*       OR DATA ALREADY SUBJECTED TO A BIT-REVERSAL PERMUTATION( ISIG=1
*       IORD=0).
*       A SPECIAL TREATMENT IS AVAILABLE TO SPEED UP THE TRANSFORM OF
*       SMALL MATRICES. THIS TREATMENT IS ACTIVATED BY THE FLAG IOPT. IN
*       THIS CASE THE TABLES FOR THE SECOND DIMENSION ( WM ) ARE LARGER,
*       BUT THE INCREASE IN PERFORMANCE IS SUBSTANTIAL WHEN NM<32.
****ARGUMENTS :
*       INPUT :
*       C : ARRAY TO BE TRANSFORMED; DECLARED COMPLEX C(ID,NM,NN) IN THE
*           CALLING PROGRAM;
*       ID : FIRST DIMENSION OF C IN THE CALLING PROGRAM
*       ISIG : OPTION FLAG : ISIG=0 : SET-UP RUN, C NOT USED
*                            ISIG=-1: DIRECT TRANSFORM
*                            ISIG=+1: INVERSE TRANSFORM
*       WL,WM,WN : INTEGER ARRAYS,USED TO HOST TABLES FOR THE TRANSFORMS
*               DIMENSIONED IN THE CALLING PROGRAM AT LEAST (4*NL+14)
*               (4*NM+14) AND (4*NN+14) RESPECTIVELY; IF IOPT=1
*               WM MUST BE DIMENSIONED AT LEAST (4*NM*(ID+1)+14)
*               IF ISIG.NE.0, THEY ARE ASSUMED TO HAVE BEEN SET BY A
*               PREVIOUS CALL WITH ISIG=0 AND OTHER ARGUMENTS EQUAL, AND
*               NEVER HAVE BEEN MODIFIED ;
*               WHEN THE CORRESPONDING ORDERS ARE EQUAL, THEY DO NOT
*               NEED TO BE DISTINCT.
*       NL : ORDER OF THE TRANSFORM ALONG THE COLUMNS OF C
*       NM : ORDER OF THE TRANSFORM ALONG THE ROWS OF C
*       NN : ORDER OF THE TRANSFORM ALONG THE THIRD DIMENSION OF C
*       IOPT : OPTION FLAG : =0 : NORMAL TREATMENT
*                            =1 : SPECIAL TREATMENT FOR IMPROVING
*                                 VECTORIZATION ON MATRICES WITH
*                                 SMALL NL; REQUIRES LONG WM(SEE);IF
*                                 REQUESTED, MUST BE PRESENT IN BOTH
*                                 THE SET-UP AND TRANSFORM CALLS;
*       IORD : OPTION FLAG : =1 : OUTPUT IN NATURAL ORDER (ISIG=-1)
*                                 INPUT IN NATURAL ORDER  (ISIG=+1)
*                            =0 : OUTPUT IN BIT-REVERSED ORDER(ISIG=-1)
*                                 INPUT IN BIT-REVERSED ORDER(ISIG=+1)
*       IWORK : INTEGER ARRAY, USED AS WORK AREA FOR REORDERING IF
*               IORD=1; IT MUST BE AT LEAST MAX(NL,NM,NN) WORDS LONG.
*
*        OUTPUT :
*       C : TRANSFORMED ARRAY
*       WL, WM, WN : ONLY IF ISIG=0, WL,WM AND WN ARE FILLED WITH THE
*                     APPROPRIATE TABLES
*       IWORK : UNDEFINED
*       IERR  : ERROR CODE : =0 : SUCCESSFUL
*                          : =1 : DATA DIMENSIONS ARE NOT CORRECT
*                            =2 : PRIME FACTORS DIFFERENT FROM 2,3,5
*                                 ARE PRESENT IN DATA DIMENSIONS
*                            =3 : TABLES NOT CORRECTLY INITIALIZED
      COMPLEX C(0:*)
      INTEGER WM(-14:*),WN(-14:*),WL(-14:*)
      INTEGER IWORK(*)
      INTEGER IDERR,FACERR,TBERR
      PARAMETER (IDERR=1,FACERR=2,TBERR=3)

      IF(ID.LT.NL)THEN
        IERR=IDERR
        RETURN
      ENDIF
      IERR=0
      IF(ISIG.EQ.0)THEN
        CALL MFFTP(NM,WM,ID*IOPT,IERR)
        IF(IERR.NE.0)RETURN
        IF(NM.NE.NN)THEN
          CALL MFFTP(NN,WN,0,IERR)
          IF(IERR.NE.0)RETURN
        ELSE
          CALL MFFTZ0(WM,1,4*NM+14,WN,1)
        ENDIF
        IF(NL.EQ.NM)THEN
          CALL MFFTZ0(WM,1,4*NM+14,WL,1)
        ELSE IF(NL.EQ.NN)THEN
          CALL MFFTZ0(WN,1,4*NN+14,WL,1)
        ELSE
          CALL MFFTP(NL,WL,0,IERR)
          IF(IERR.NE.0)RETURN
        ENDIF
        RETURN

      ELSE   IF(ISIG.GT.0)THEN

        IF(IORD.NE.0)THEN
          CALL MFFTOV(C,1,ID,NL,NM*NN,WL(3*NL),IWORK)
          CALL MFFTOV(C,ID*NM,1,NN,ID*NM,WN(3*NN),IWORK)
          CALL MFFTOM(C,ID,ID*NM,1,NM,NN,NL,WM(3*NM),
     $                IWORK)
        ENDIF
        CALL MFFTIV(C,1,ID,NL,NM*NN,WL,IERR)
        IF(IERR.NE.0)RETURN
        IF(IOPT.EQ.0)THEN
          CALL MFFTIM(C,ID,ID*NM,1,NM,NN,NL,WM,IERR)
          IF(IERR.NE.0)RETURN
        ELSE
          CALL MFFTIS(C,ID,ID*NM,1,NM,NN,NL,WM,IERR)
          IF(IERR.NE.0)RETURN
        ENDIF
        CALL MFFTIV(C,ID*NM,1,NN,ID*NM,WN,IERR)
        IF(IERR.NE.0)RETURN

      ELSE

        CALL MFFTDV(C,1,ID,NL,NM*NN,WL,IERR)
        IF(IERR.NE.0)RETURN
        IF(IOPT.EQ.0)THEN
          CALL MFFTDM(C,ID,ID*NM,1,NM,NN,NL,WM,IERR)
          IF(IERR.NE.0)RETURN
        ELSE
          CALL MFFTDS(C,ID,ID*NM,1,NM,NN,NL,WM,IERR)
          IF(IERR.NE.0)RETURN
        ENDIF
        CALL MFFTDV(C,ID*NM,1,NN,ID*NM,WN,IERR)
        IF(IERR.NE.0)RETURN
        IF(IORD.NE.0)THEN
          CALL MFFTOV(C,1,ID,NL,NM*NN,WL(2*NL),IWORK)
          CALL MFFTOV(C,ID*NM,1,NN,ID*NM,WN(2*NN),IWORK)
          CALL MFFTOM(C,ID,ID*NM,1,NM,NN,NL,WM(2*NM),
     $                IWORK)
        ENDIF

      ENDIF

      END


C Copyright (C) 2009 International Business Machines.
C All Rights Reserved.
C This code is published under the Eclipse Public License.
C
C    $Id: hs071_f.f.in 699 2006-04-05 21:05:18Z andreasw $
C
C Author:  Andreas Waechter               IBM    2009-04-02
C
C =============================================================================
C
C  This file is part of the Ipopt tutorial.  It is a correct version
C  of a Fortran implemention of the coding exercise problem
C  (in AMPL formulation):
C
C  param n := 4;
C
C  var x {1..n} <= 0, >= -1.5, := -0.5;
C
C  minimize obj:
C    sum{i in 1..n} (x[i]-1)^2;
C
C  subject to constr {i in 2..n-1}:
C    (x[i]^2+1.5*x[i]-i/n)*cos(x[i+1]) - x[i-1] = 0;
C
C  The constant term "i/n" in the constraint is supposed to be input data
C
C =============================================================================
C
C
C =============================================================================
C
C                            Main driver program
C
C =============================================================================
C
      program tutorial
C
      implicit none
C
C     include the Ipopt return codes
C
      include 'IpReturnCodes.inc'
C
C     Size of the problem (number of variables and equality constraints)
C
      integer     NMAX, MMAX, IDX_STY
      parameter  (NMAX = 1000, MMAX = 1000, IDX_STY = 1 )
      integer     N,     M,     NELE_JAC,     NELE_HESS
C
C     Space for multipliers and constraints
C
      double precision LAM(MMAX)
      double precision G(MMAX)
C
C     Vector of variables
C
      double precision X(NMAX)
C
C     Vector of lower and upper bounds
C
      double precision X_L(NMAX), X_U(NMAX), Z_L(NMAX), Z_U(NMAX)
      double precision G_L(MMAX), G_U(MMAX)
C
C     Private data for evaluation routines
C     This could be used to pass double precision and integer arrays untouched
C     to the evaluation subroutines EVAL_*
C
      double precision DAT(MMAX)
      integer IDAT(1)
C
C     Place for storing the Ipopt Problem Handle
C
CC     for 32 bit platforms
C      integer IPROBLEM
C      integer IPCREATE
C     for 64 bit platforms:
      integer*8 IPROBLEM
      integer*8 IPCREATE
C
      integer IERR
      integer IPSOLVE, IPADDSTROPTION
      integer IPADDNUMOPTION, IPADDINTOPTION
      integer IPOPENOUTPUTFILE
C
      double precision f
      integer i
C
C     The following are the Fortran routines for computing the model
C     functions and their derivatives - their code can be found furhter
C     down in this file.
C
      external EV_F, EV_G, EV_GRAD_F, EV_JAC_G, EV_HESS
C
C     Set the problem size
C
      N = 100
C
C     Number of constraints
C
      M = N - 2
C
C     Number of nonzeros in constraint Jacobian
C
      NELE_JAC = 3*M
C
C     Number of nonzeros in Lagrangian Hessian
C
      NELE_HESS = N + (N-2)
C
C     Set initial point and bounds
C
      do i = 1, N
         X_L(i) = -1.5d0
         X_U(i) = -0.d0
         X(i)   = -0.5d0
C     if checking derivatives,it is useful to choose different values
C         X(i) = -0.5d0 + 0.1d0*DBLE(i)/DBLE(N);
      enddo
C
C     Set bounds for the constraints
C
      do i = 1, M
         G_L(i) = 0.d0
         G_U(i) = 0.d0
      enddo
C
C     First create a handle for the Ipopt problem (and read the options
C     file)
C
      IPROBLEM = IPCREATE(N, X_L, X_U, M, G_L, G_U, NELE_JAC, NELE_HESS,
     1     IDX_STY, EV_F, EV_G, EV_GRAD_F, EV_JAC_G, EV_HESS)
      if (IPROBLEM.eq.0) then
         write(*,*) 'Error creating an Ipopt Problem handle.'
         stop
      endif
C
C     Open an output file
C
      IERR = IPOPENOUTPUTFILE(IPROBLEM, 'IPOPT.OUT', 5)
      if (IERR.ne.0 ) then
         write(*,*) 'Error opening the Ipopt output file.'
         goto 9000
      endif
C
C     Note: The following options are only examples, they might not be
C           suitable for your optimization problem.
C
C     Set a string option
C
      IERR = IPADDSTROPTION(IPROBLEM, 'mu_strategy', 'adaptive')
      if (IERR.ne.0 ) goto 9990
C
C     Set an integer option
C
      IERR = IPADDINTOPTION(IPROBLEM, 'max_iter', 3000)
      if (IERR.ne.0 ) goto 9990
C
C     Set a double precision option
C
      IERR = IPADDNUMOPTION(IPROBLEM, 'tol', 1.d-7)
      if (IERR.ne.0 ) goto 9990
C
C     Prepare the private data
C
      IDAT(1) = N
      do i = 1, M
         DAT(i) = DBLE(i+1)/DBLE(N)
      enddo
C
C     Call optimization routine
C
      IERR = IPSOLVE(IPROBLEM, X, G, F, LAM, Z_L, Z_U, IDAT, DAT)
C
C     Output:
C
      if( IERR.eq.IP_SOLVE_SUCCEEDED ) then
         write(*,*)
         write(*,*) 'The solution was found.'
         write(*,*)
         write(*,*) 'The final value of the objective function is ',f
         write(*,*)
         write(*,*) 'The optimal values of X are:'
         write(*,*)
         do i = 1, N
            write(*,*) 'X  (',i,') = ',X(i)
         enddo
         write(*,*)
         write(*,*) 'The multipliers for the lower bounds are:'
         write(*,*)
         do i = 1, N
            write(*,*) 'Z_L(',i,') = ',Z_L(i)
         enddo
         write(*,*)
         write(*,*) 'The multipliers for the upper bounds are:'
         write(*,*)
         do i = 1, N
            write(*,*) 'Z_U(',i,') = ',Z_U(i)
         enddo
         write(*,*)
         write(*,*) 'The multipliers for the equality constraints are:'
         write(*,*)
         do i = 1, M
            write(*,*) 'LAM(',i,') = ',LAM(i)
         enddo
         write(*,*)
      else
         write(*,*)
         write(*,*) 'An error occoured.'
         write(*,*) 'The error code is ',IERR
         write(*,*)
      endif
C
 9000 continue
C
C     Clean up
C
      call IPFREE(IPROBLEM)
      stop
C
 9990 continue
      write(*,*) 'Error setting an option'
      goto 9000
      end
C
C =============================================================================
C
C                    Computation of objective function
C
C =============================================================================
C
      subroutine EV_F(N, X, NEW_X, F, IDAT, DAT, IERR)
      implicit none
      integer N, NEW_X
      double precision F, X(N)
      double precision DAT(*)
      integer IDAT(*)
      integer IERR
      integer i

      F = 0.d0
      do i = 1, N
         F = F + (X(i)-1.d0)**2
      enddo
      IERR = 0
      return
      end
C
C =============================================================================
C
C                Computation of gradient of objective function
C
C =============================================================================
C
      subroutine EV_GRAD_F(N, X, NEW_X, GRAD, IDAT, DAT, IERR)
      implicit none
      integer N, NEW_X
      double precision GRAD(N), X(N)
      double precision DAT(*)
      integer IDAT(*)
      integer IERR
      integer i

      do i = 1, N
         GRAD(i) = 2.d0*(X(i)-1.d0)
      enddo

      IERR = 0
      return
      end
C
C =============================================================================
C
C                     Computation of equality constraints
C
C =============================================================================
C
      subroutine EV_G(N, X, NEW_X, M, G, IDAT, DAT, IERR)
      implicit none
      integer N, NEW_X, M
      double precision G(M), X(N)
      double precision DAT(*)
      integer IDAT(*)
      integer IERR
      integer j

      do j = 1, M
         G(j) = (X(j+1)**2 + 1.5d0*X(j+1) - DAT(j))*COS(X(j+2)) - X(j)
      enddo

      IERR = 0
      return
      end
C
C =============================================================================
C
C                Computation of Jacobian of equality constraints
C
C =============================================================================
C
      subroutine EV_JAC_G(TASK, N, X, NEW_X, M, NZ, ACON, AVAR, A,
     1     IDAT, DAT, IERR)
      integer TASK, N, NEW_X, M, NZ
      double precision X(N), A(NZ)
      integer ACON(NZ), AVAR(NZ)
      double precision DAT(*)
      integer IDAT(*)
      integer IERR
      integer j, inz
C
      if( TASK.eq.0 ) then
         inz = 1
         do j = 1, M
            ACON(inz) = j
            AVAR(inz) = j
            inz = inz + 1
            ACON(inz) = j
            AVAR(inz) = j + 1
            inz = inz + 1
            ACON(inz) = j
            AVAR(inz) = j + 2
            inz = inz + 1
         enddo
      else
         inz = 1
         do j = 1, M
            A(inz) = -1.d0
            inz = inz + 1
            A(inz) = (2.d0*X(j+1)+1.5d0)*COS(X(j+2))
            inz = inz + 1
            A(inz) = -(x(j+1)**2 + 1.5d0*X(j+1) - DAT(j))*SIN(X(j+2))
            inz = inz + 1
         enddo
      endif
      IERR = 0
      return
      end
C
C =============================================================================
C
C                Computation of Hessian of Lagrangian
C
C =============================================================================
C
      subroutine EV_HESS(TASK, N, X, NEW_X, OBJFACT, M, LAM, NEW_LAM,
     1     NNZH, IRNH, ICNH, HESS, IDAT, DAT, IERR)
      implicit none
      integer TASK, N, NEW_X, M, NEW_LAM, NNZH
      double precision X(N), OBJFACT, LAM(M), HESS(NNZH)
      integer IRNH(NNZH), ICNH(NNZH)
      double precision DAT(*)
      integer IDAT(*)
      integer IERR
      integer i, inz
C
      if( TASK.eq.0 ) then
         inz = 1

         IRNH(inz) = 1
         ICNH(inz) = 1
         inz = inz + 1

         do i = 2, N-1
            IRNH(inz) = i
            ICNH(inz) = i
            inz = inz + 1
            IRNH(inz) = i
            ICNH(inz) = i + 1
            inz = inz + 1
         enddo

         IRNH(inz) = N
         ICNH(inz) = N
         inz = inz + 1
      else
         inz = 1

         HESS(inz) = OBJFACT*2.d0
         inz = inz + 1

         do i = 2, N-1
            HESS(inz) = OBJFACT*2.d0 + LAM(i-1)*2.d0*COS(X(i+1))
            if (i.gt.2) then
               HESS(inz) = HESS(inz) - LAM(i-2)*(X(i-1)**2
     1              + 1.5d0*X(i-1) - DAT(i-2))*COS(X(i))
            endif
            inz = inz + 1

            HESS(inz) = -LAM(i-1)*(2.d0*X(i)+1.5d0)*SIN(X(i+1))
            inz = inz + 1
        enddo

        HESS(inz) = OBJFACT*2.d0 - LAM(N-2)*(X(N-1)**2 + 1.5d0*X(N-1)
     1       - DAT(N-2))*COS(X(N))

      endif
      IERR = 0
      return
      end


submodule (stdlib_linalg) stdlib_linalg_outer_product

  implicit none

contains

    pure module function outer_product_rsp(u, v) result(res)
      real(sp), intent(in) :: u(:), v(:)
      real(sp) :: res(size(u),size(v))
      integer :: col
      do col = 1, size(v)
        res(:,col) = v(col) * u
      end do
    end function outer_product_rsp
    pure module function outer_product_rdp(u, v) result(res)
      real(dp), intent(in) :: u(:), v(:)
      real(dp) :: res(size(u),size(v))
      integer :: col
      do col = 1, size(v)
        res(:,col) = v(col) * u
      end do
    end function outer_product_rdp
    pure module function outer_product_rqp(u, v) result(res)
      real(qp), intent(in) :: u(:), v(:)
      real(qp) :: res(size(u),size(v))
      integer :: col
      do col = 1, size(v)
        res(:,col) = v(col) * u
      end do
    end function outer_product_rqp
    pure module function outer_product_csp(u, v) result(res)
      complex(sp), intent(in) :: u(:), v(:)
      complex(sp) :: res(size(u),size(v))
      integer :: col
      do col = 1, size(v)
        res(:,col) = v(col) * u
      end do
    end function outer_product_csp
    pure module function outer_product_cdp(u, v) result(res)
      complex(dp), intent(in) :: u(:), v(:)
      complex(dp) :: res(size(u),size(v))
      integer :: col
      do col = 1, size(v)
        res(:,col) = v(col) * u
      end do
    end function outer_product_cdp
    pure module function outer_product_cqp(u, v) result(res)
      complex(qp), intent(in) :: u(:), v(:)
      complex(qp) :: res(size(u),size(v))
      integer :: col
      do col = 1, size(v)
        res(:,col) = v(col) * u
      end do
    end function outer_product_cqp
    pure module function outer_product_iint8(u, v) result(res)
      integer(int8), intent(in) :: u(:), v(:)
      integer(int8) :: res(size(u),size(v))
      integer :: col
      do col = 1, size(v)
        res(:,col) = v(col) * u
      end do
    end function outer_product_iint8
    pure module function outer_product_iint16(u, v) result(res)
      integer(int16), intent(in) :: u(:), v(:)
      integer(int16) :: res(size(u),size(v))
      integer :: col
      do col = 1, size(v)
        res(:,col) = v(col) * u
      end do
    end function outer_product_iint16
    pure module function outer_product_iint32(u, v) result(res)
      integer(int32), intent(in) :: u(:), v(:)
      integer(int32) :: res(size(u),size(v))
      integer :: col
      do col = 1, size(v)
        res(:,col) = v(col) * u
      end do
    end function outer_product_iint32
    pure module function outer_product_iint64(u, v) result(res)
      integer(int64), intent(in) :: u(:), v(:)
      integer(int64) :: res(size(u),size(v))
      integer :: col
      do col = 1, size(v)
        res(:,col) = v(col) * u
      end do
    end function outer_product_iint64

end submodule


      SUBROUTINE MA02EZ( UPLO, TRANS, SKEW, N, A, LDA )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To store by (skew-)symmetry the upper or lower triangle of a
C     (skew-)symmetric/Hermitian complex matrix, given the other
C     triangle.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPLO    CHARACTER*1
C             Specifies which part of the matrix is given as follows:
C             = 'U':  Upper triangular part;
C             = 'L':  Lower triangular part.
C             For all other values, the array A is not referenced.
C
C     TRANS   CHARACTER*1
C             Specifies whether to use transposition or conjugate
C             transposition as follows:
C             = 'T':  Use transposition;
C             = 'C':  Use conjugate transposition.
C
C     SKEW    CHARACTER*1
C             Specifies whether the matrix is symmetric/Hermitian or
C             skew-symmetric/Hermitian as follows:
C             = 'N':  The matrix is symmetric/Hermitian;
C             = 'S':  The matrix is skew-symmetric/Hermitian.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     A       (input/output) COMPLEX*16 array, dimension (LDA,N)
C             On entry, the leading N-by-N upper triangular part
C             (if UPLO = 'U'), or lower triangular part (if UPLO = 'L'),
C             of this array must contain the corresponding upper or
C             lower triangle of the (skew-)symmetric/Hermitian matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the (skew-)symmetric/Hermitian matrix A with all elements
C             stored. If the resulted matrix should be Hermitian, the
C             imaginary parts of the diagonal entries are set to zero.
C             If the resulted matrix should be skew-Hermitian, the real
C             parts of the diagonal entries are set to zero.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Sep. 2012. Based on SLICOT Library routine MA02ED.
C
C     REVISIONS
C
C     V. Sima, Jan. 2016.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      CHARACTER          SKEW, TRANS, UPLO
      INTEGER            LDA, N
C     .. Array Arguments ..
      COMPLEX*16         A(LDA,*)
C     .. Local Scalars ..
      INTEGER            I, J
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     ..Intrinsic Functions..
      INTRINSIC          DBLE, DCONJG, DIMAG
C
C     .. Executable Statements ..
C
C     For efficiency reasons, the parameters are not checked for errors.
C
      IF( LSAME( UPLO, 'L' ) ) THEN
C
C        Construct the upper triangle of A.
C
         IF( LSAME( TRANS, 'T' ) ) THEN
C
            IF( LSAME( SKEW, 'N' ) ) THEN
C
               DO 20 I = 1, N
                  DO 10 J = 2, N
                     A(I,J) = A(J,I)
   10             CONTINUE
   20          CONTINUE
C
            ELSE
C
               DO 40 I = 1, N
                  DO 30 J = 2, N
                     A(I,J) = -A(J,I)
   30             CONTINUE
   40          CONTINUE
C
            END IF
C
         ELSE
C
            IF( LSAME( SKEW, 'N' ) ) THEN
C
               DO 60 I = 1, N
                  A(I,I) = DBLE( A(I,I) )
                  DO 50 J = 2, N
                     A(I,J) = DCONJG( A(J,I) )
   50             CONTINUE
   60          CONTINUE
C
            ELSE
C
               DO 80 I = 1, N
                  A(I,I) = DIMAG( A(I,I) )
                  DO 70 J = 2, N
                     A(I,J) = -DCONJG( A(J,I) )
   70             CONTINUE
   80          CONTINUE
C
            END IF
C
         END IF
C
      ELSE IF( LSAME( UPLO, 'U' ) ) THEN
C
C        Construct the lower triangle of A.
C
         IF( LSAME( TRANS, 'T' ) ) THEN
C
            IF( LSAME( SKEW, 'N' ) ) THEN
C
               DO 100 I = 1, N
                  DO 90 J = 2, N
                     A(J,I) = A(I,J)
   90             CONTINUE
  100          CONTINUE
C
            ELSE
C
               DO 120 I = 1, N
                  DO 110 J = 2, N
                     A(J,I) = -A(I,J)
  110             CONTINUE
  120          CONTINUE
C
            END IF
C
         ELSE
C
            IF( LSAME( SKEW, 'N' ) ) THEN
C
               DO 140 I = 1, N
                  A(I,I) = DBLE( A(I,I) )
                  DO 130 J = 2, N
                     A(J,I) = DCONJG( A(I,J) )
  130             CONTINUE
  140          CONTINUE
C
            ELSE
C
               DO 160 I = 1, N
                  A(I,I) = DIMAG( A(I,I) )
                  DO 150 J = 2, N
                     A(J,I) = -DCONJG( A(I,J) )
  150             CONTINUE
  160          CONTINUE
C
            END IF
C
         END IF
C
      END IF
      RETURN
C *** Last line of MA02EZ ***
      END


SUBROUTINE MNBRAK(AX,BX,CX,FA,FB,FC,FUNC)
!Given a function FUNC(X), and given distinct initial points AX and
!BX, this routine searches in the downhill direction (defined by the
!function as evaluated at the initial points) and returns new points
!AX, BX, CX which bracket a minimum of the function. Also returned
!are the function values at the three points, FA, FB and FC.

IMPLICIT NONE

double precision,INTENT(INOUT)	:: AX,BX
double precision,INTENT(OUT)		:: CX,FA,FB,FC

double precision	::DUM,FU,Q,R,U,ULIM,GOLD,GLIMIT,TINY,FUNC

INTEGER	:: ITER	!added by greg to avoid getting stuck in an infinite loop
PARAMETER(GOLD=1.618034,GLIMIT=100.,TINY=1.D-20)
!The first parameter is the default ratio by which successive intervals
!are magnified; the second is the maximum magnification allowed for
!a parabolic-fit step.

EXTERNAL FUNC

FA=FUNC(AX)
FB=FUNC(BX)
IF(FB.GT.FA) THEN
  DUM=AX
  AX=BX
  BX=DUM
  DUM=FB
  FB=FA
  FA=DUM
ENDIF
CX=BX+GOLD*(BX-AX)
FC=FUNC(CX)
ITER = 1
1 IF((FB.GE.FC) .and. ITER<=25) THEN
	ITER = ITER +1
  R=(BX-AX)*(FB-FC)
  Q=(BX-CX)*(FB-FA)
  U=BX-((BX-CX)*Q-(BX-AX)*R)/(2.*SIGN(MAX(ABS(Q-R),TINY),Q-R))
  ULIM=BX+GLIMIT*(CX-BX)
  IF((BX-U)*(U-CX).GT.0) THEN
    FU=FUNC(U)
    IF(FU.LT.FC) THEN
	  AX=BX
	  FA=FB
	  BX=U
	  FB=FU
	  GOTO 1
    ELSE IF(FU.GT.FB) THEN
	  CX=U
	  FC=FU
	  GOTO 1
    ENDIF
	U=CX+GOLD*(CX-BX)
	FU=FUNC(U)
  ELSE IF((CX-U)*(U-ULIM).GT.0) THEN
    FU=FUNC(U)
	IF(FU.LT.FC) THEN
	  BX=CX
	  CX=U
	  U=CX+GOLD*(CX-BX)
	  FB=FC
	  FC=FU
	  FU=FUNC(U)
    ENDIF
  ELSE IF((U-ULIM)*(ULIM-CX).GE.0) THEN
    U=ULIM
	FU=FUNC(U)
  ELSE
    U=CX+GOLD*(CX-BX)
	FU=FUNC(U)
  ENDIF
  AX=BX
  BX=CX
  CX=U
  FA=FB
  FB=FC
  FC=FU
  GOTO 1
ENDIF

IF(ITER>=100) THEN
 CX=AX
 FC=FA
	write(*,*) ' prob in mnbrak: too many iterations'
END IF

RETURN
END


      subroutine hrtmp(hour,halfdy)
c
c     +++PURPOSE+++
c     This function distributes the diurnal (daily) temperature
c     on an hourly basis.  The actual routine to do so was
c     written by DeWet, etal.,1978 and tested by Reicosky etal 1988.
c     DeWet was taken from "simulation of Simulation, Respiration,
c     and Transpiration" while Reicosky is from "Accuracy of
c     Hourly Air Temperatures Calculated from Daily Minima and Maxima.

c     Authors(s):  John Witte, UofMn WCES @ USDA-ARS-NCSRL
c     Date: 04/01/93

c     Verified and tested by Reza Savabi, USDA-ARS, NSERL 317-494-5051
c                  August 1994
c
c     +++ARGUMENT DECLARATIONS+++
      real    halfdy
      integer hour
c
c     +++ARGUMENT DEFINITIONS+++
c     halfdy - The amount of time from sunrise until noon (hrs).
c     hour   - The hour of the day that is currently being run.
c
c     + + + PARAMETERS + + +
c
      include 'pmxpln.inc'
      include 'pmxhil.inc'
c
c     +++COMMON BLOCKS+++
      include  'cclim.inc'
c       read:  tave,tmax,tmin,tdpt
c       modify: hrtemp,hrdewp
c
c     +++LOCAL VARIABLES+++
      save
      real    pi,adjhr,amp,sunris
c
c     +++LOCAL DEFINITIONS+++
c     pi     - Estimated value for 22/7.
c     adjhr  - Hour value adjustment made to deal with middle of hour.
c     amp    - The ampilitude of the temperature graph.
c     sunris - Hour of the day which sunrise occures (hr).
c
c     +++DATA INITIALIZATIONS+++
      data   pi/3.14159/
c
c     +++END SPECIFICATIONS+++

      sunris = 12.0 - halfdy
      tave = (tmax + tmin) / 2
      amp  = (tmax - tmin) / 2

      if ((hour .lt. sunris) .or. (14.0 .lt. hour)) then
        if (hour .lt. sunris) then
          adjhr = (hour - 0.5) + 10.0
        else
          adjhr = (hour - 0.5) - 14.0
        endif
cd    It is wrong to calculate dewpoint temperature this way!
cd    S. Dun, Aug 11, 2007
        hrtemp = tave + amp * (cos((pi * adjhr) / (10 + sunris)))
cd        hrdewp = tdpt + amp * (cos((pi * adjhr) / (10 + sunris)))
      else
        hrtemp = tave - amp * (cos(pi * (hour - 0.5 - sunris) /
     1            (14 - sunris)))
cd        hrdewp = tdpt - amp * (cos(pi * (hour - 0.5 - sunris) /
cd     1            (14 - sunris)))
      endif

      return
      end


Function fhin(x)
  Common /hparnt/hipr1(100), ihpr2(50), hint1(100), ihnt2(50)
  Save
  omg = omg0(x)*(hipr1(30)+hint1(11))/hipr1(31)/2.0
  fhin = 1.0 - exp(-2.0*omg)
  Return
End Function fhin


      SUBROUTINE DSYMMV( N, A, pointers, indices, X, Y )
c
c     Purpose:
c
c     This subroutine performs sparse symmetric matrix-vector
c     multiplication
c
c                 y <---- A*x
c
c     Arguements:
c
c     N          INTEGER (INPUT).
c                Dimension of the matrix
c
c     A          DOUBLE PRECISION array of size NNZ (INPUT).
c                Nonzero entries of a sparse matrix A.
c
c     POINTERS   INTEGER array of size N+1. (INPUT)
c                Column pointers of A.  POINTERS(j) gives the
c                index of the starting point of column j in A.
c                NNZ = COLPTR(j+1)-1
c
c     INDICES    INTEGER array of size NNZ. (INPUT)
c                The row indices of each nonzero entry in A.
c
c     X          INTEGER array of size N. (INPUT)
c                The input vector.
c
c     Y          INTEGER array of size N. (OUTPUT)
c                The output vector.
*
*     .. Scalar Arguments ..
      INTEGER            N
*     ..
*     .. Array Arguments ..
      INTEGER            pointers( * ), indices( * )
      DOUBLE PRECISION   A( * )
      DOUBLE PRECISION   X( * ), Y( * )
*
*==============================================================
*
*  does a sparse matrix * vector multiplication to compute
*
*                   y = A * x
*
*  where A is stored in the sparse column format
*
*==============================================================
*
*     .. Parameter ..
*
*     .. Local Scalars ..
      INTEGER            I, J, K, K1, K2
*
*     Initialization
*
      DO 10 J = 1, N
	 Y( J ) = 0.0d0
  10  CONTINUE
*
*     Compute y = A*x
*
      DO 100 J = 1,N
         K1 = pointers( J )
         K2 = pointers( J+1 ) -1
         DO 110 K = K1, K2
            I = indices( K )
*
*           Compute y(i) = y(i) + a(i,j) * x(j)
*
            Y( I ) = Y( I ) + A( K )*X( J )
*
	    if (i .ne. j) then
               y(j) = y(j) + a(k)*x(i)
            endif
*
 110     CONTINUE
 100  CONTINUE
*
*     End of DSYMMV
*
      END


== Computes the greatest common divider of given numbers `a` and `b`.
==
== Returns: Number
gcd (a, b) -> a > b ? gcd (a - b, b)
            : a < b ? gcd (a, b - a)
            : a


program energy

 != unit (m) :: height
 != unit (kg) :: mass
 != unit (m / s**2) :: gravity
 real, parameter :: mass = 3.00, gravity = .81, height = 4.20

 != unit (1) :: i
 integer :: i = 0
 != unit (1) :: j
 integer :: j = i

 != unit (kg m**2 / s**2) :: potential_energy
 real :: potential_energy

 potential_energy = mass * gravity * height
end program energy


      subroutine bn_vecpot
c ----------------------------------------------------------------------
c     purpose:                                               11.08.99

c
c
c ---------------------------------------------------------------------
      use meshes
      use bnvariables
      implicit none
c ----------------------------------------------------------------------
      integer :: i, ip
      real(rprec), dimension(:), allocatable :: ax, ay, az, analyt
      real(rprec) :: pi41, dintu, dintv, pi21
c ----------------------------------------------------------------------
      allocate (ax(nuv), ay(nuv), az(nuv), analyt(nuv),stat=i)

      pi41  = .5_dp/pi2
      pi21  = 1._dp/pi2
      ax   = 0;      ay   = 0;      az   = 0

      do i = 1,nuv
         call vecpot (ax(i), ay(i), az(i), i, 1, i-1)
         call vecpot (ax(i), ay(i), az(i), i, i+1, nuvp)
      enddo

!      do i=1,nuv
!      print *,ax(i),ay(i),az(i)
!      enddo

!     FREE UP BIG ARRAYS
      deallocate (x, y, z, indu, indv, djx, djy, djz)

      call regint(analyt, guu, guv, gvv, nuv) ! compute  singular  integral

      do  i  = 1,nuv
         dintu = (ax(i)*xu(i)+ay(i)*yu(i)+az(i)*zu(i))*fnuv
         dintv = (ax(i)*xv(i)+ay(i)*yv(i)+az(i)*zv(i))*fnuv
         au(i) = pi41*(dintu +dju(i)*analyt(i)*np)
         av(i) = pi41*(dintv +djv(i)*analyt(i)*np)
      enddo

      deallocate (ax, ay, az, analyt)

!     end  subroutine bn_vecpot
      end


C
C Test SUBROUTINE for von Mises material with linear isotropic hardening
C [With Consistent Tangent Constitutive Matrix]
C
C Written by Kostas Papanikolopoulos, 04/11/2004
C
      SUBROUTINE VMCUMAT(STRESS,STATEV,DDSDDE,SSE,SPD,SCD,
     1 RPL,DDSDDT,DRPLDE,DRPLDT,
     2 STRAN,DSTRAN,TIME,DTIME,TEMP,DTEMP,PREDEF,DPRED,CMNAME,
     3 NDI,NSHR,NTENS,NSTATV,PROPS,NPROPS,COORDS,DROT,PNEWDT,
     4 CELENT,DFGRD0,DFGRD1,NOEL,NPT,LAYER,KSPT,KSTEP,KINC)
C
C      INCLUDE 'ABA_PARAM.INC'
C
      CHARACTER*80 CMNAME
      DIMENSION STRESS(NTENS),STATEV(NSTATV),
     1 DDSDDE(NTENS,NTENS),
     2 DDSDDT(NTENS),DRPLDE(NTENS),
     3 STRAN(NTENS),DSTRAN(NTENS),TIME(2),PREDEF(1),DPRED(1),
     4 PROPS(NPROPS),COORDS(3),DROT(3,3),DFGRD0(3,3),DFGRD1(3,3)
C
C The above lines are needed by ABAQUS
C User variables are declared below
C
      DIMENSION STR_EL(6),D_EL(6,6),STR_DEV(6)
C STR_EL(6) = Elastic stress predictor
C D_EL(6,6) = Elastic constitutive matrix
C STR_DEV(6)= (New) Deviatoric stress tensor --> Used to form DDSDDE
	DIMENSION ARRAY_K(6,6)
	DATA ARRAY_K   / 0., -1., -1., 0., 0., 0.,
     &				-1.,  0., -1., 0., 0., 0.,
     &				-1., -1.,  0., 0., 0., 0.,
     &				 0.,  0.,  0., .5, 0., 0.,
     &				 0.,  0.,  0., 0., .5, 0.,
     &				 0.,  0.,  0., 0., 0., .5  /
C ARRAY_K(6,6) = Array needed for consistent constitutive matrix formulation
C
C Check the size of the stress or strain component array
      IF(NTENS.NE.6) THEN
	  WRITE(6,*) "FATAL ERROR IN UMAT. SEE .msg FILE FOR DETAILS"
	  WRITE(7,*) "FATAL ERROR IN UMAT: NTENS IS NOT 6"
	  WRITE(7,*) "PLEASE USE ONLY CONTINUUM (SOLID) ELEMENTS"
	  WRITE(7,*) "WITH THIS MATERIAL MODEL."
	  WRITE(7,*) "EXITING"
c	  CALL XIT
	  STOP
	ENDIF
C
C Evaluate elastic constitutive matrix
C
      DO K1=1,NTENS
        DO K2=1,NTENS
          D_EL(K2,K1) = 0.
        END DO
      END DO
C PROPS(1)=E (Young's modulus), PROPS(2)=nu (Poisson's ratio)
C Do not use nu=0.5 (incrompressible solid)
	C1 = PROPS(1)*(1.-PROPS(2))/(1.+PROPS(2))/(1.-2.*PROPS(2))
	C2 = PROPS(1)*PROPS(2)/(1.+PROPS(2))/(1.-2.*PROPS(2))
	C3 = PROPS(1)/(1.+PROPS(2))/2.
C
      D_EL(1,1) = C1
      D_EL(2,2) = C1
      D_EL(3,3) = C1
C
      D_EL(1,2) = C2
      D_EL(1,3) = C2
      D_EL(2,1) = C2
      D_EL(2,3) = C2
      D_EL(3,1) = C2
      D_EL(3,2) = C2
C
      D_EL(4,4) = C3
      D_EL(5,5) = C3
      D_EL(6,6) = C3
C
C EVALUATE NEW STRESS TENSOR and STATE VARIABLE
C
C Calculate trial (elastic) stress state
	STR_EL = STRESS+MATMUL(D_EL,DSTRAN)
C Yield function <>0 ?
C PROPS(3)=sigma(y) (initial yield stress),
C PROPS(4)=h (hardening modulus for linear hardening)
C STATEV(1)=epsilon(p)_BAR (accumulated plastic strain)
	CJ2_EL = ( (STR_EL(1)-STR_EL(2))**2.+(STR_EL(2)-STR_EL(3))**2.+
     &           (STR_EL(3)-STR_EL(1))**2. )/6.+
     &         STR_EL(4)**2.+STR_EL(5)**2.+STR_EL(6)**2.
	IF (SQRT(3.*CJ2_EL)-(PROPS(3)+PROPS(4)*STATEV(1)).LE.0.) THEN
	  STRESS=STR_EL     ! No plastic correction needed
	  DDSDDE=D_EL       ! Const. matrix = Elastic const. matrix
	  GOTO 900          ! No change to the accumulated plastic strain
	ENDIF
C Return mapping
	G=PROPS(1)/2./(1.+PROPS(2))    ! G = Shear modulus
	DEPSILONP = (SQRT(3.*CJ2_EL)-(PROPS(3)+PROPS(4)*STATEV(1)))/
     &            (3.*G+PROPS(4))
	STATEV(1)=STATEV(1)+DEPSILONP  ! Update accumulated plastic strain
	CCC = G*DEPSILONP*SQRT(3./CJ2_EL)   ! 2. and 1/2. cancel out
	P_EL = (STR_EL(1)+STR_EL(2)+STR_EL(3))/3.  ! P_EL=mean stress (elastic)
	STRESS(1) = STR_EL(1)-CCC*(STR_EL(1)-P_EL)
	STRESS(2) = STR_EL(2)-CCC*(STR_EL(2)-P_EL)
	STRESS(3) = STR_EL(3)-CCC*(STR_EL(3)-P_EL)
	STRESS(4) = STR_EL(4)-CCC*STR_EL(4)
	STRESS(5) = STR_EL(5)-CCC*STR_EL(5)
	STRESS(6) = STR_EL(6)-CCC*STR_EL(6)
C
C CREATE NEW JACOBIAN
C
	P_NEW = (STRESS(1)+STRESS(2)+STRESS(3))/3.
	STR_DEV(1) = STRESS(1)-P_NEW
	STR_DEV(2) = STRESS(2)-P_NEW
	STR_DEV(3) = STRESS(3)-P_NEW
	STR_DEV(4) = STRESS(4)
	STR_DEV(5) = STRESS(5)
	STR_DEV(6) = STRESS(6)
C
	CJ2_NEW = ( (STRESS(1)-STRESS(2))**2.+(STRESS(2)-STRESS(3))**2.+
     &            (STRESS(3)-STRESS(1))**2. )/6.+
     &          STRESS(4)**2.+STRESS(5)**2.+STRESS(6)**2.
	CCC=3.*G*G/(PROPS(4)+3.*G)/CJ2_NEW
	DDD=2.*SQRT(3.)*G*G*DEPSILONP/SQRT(CJ2_EL)
	EEE=.5/CJ2_NEW

      DO K1=1,NTENS
        DO K2=1,NTENS
          DDSDDE(K2,K1) = D_EL(K2,K1)-CCC*STR_DEV(K2)*STR_DEV(K1)
     &				-DDD*(ARRAY_K(K2,K1)-EEE*STR_DEV(K2)*STR_DEV(K1))
        END DO
      END DO
C
  900 CONTINUE
	RETURN
	END


module pressure_update

  ! The initial exner term is calculated in subroutine z2exner (in test_cases.f90).
  ! This is assumed to constant in the horizontal, which is OK for fixed_theta,
  ! but not good when theta responds to advection and microphysics. This routine
  ! updates the pressure term depending on T so that density can vary depending on
  ! theta
  Use column_variables
  Use physconst, only : Ru=>R, r_on_cp, g, p0, pi, cp
  Use parameters, only : nz, nx
  Use interpolation, only : interpolate, smooth1D

  Implicit none

contains

  subroutine exner_timestep_upd(theta_local)

    ! Update the exner term depending on theta

    real(wp), intent(in) :: theta_local(:,0:)
    ! theta_local is theta when called from stepfields.f90 and theta +
    ! (dtheta_adv(k,i)+dtheta_div(k,i))*dt when called before mphys
    !
    integer :: k, j

    do j=1,nx
       ! call smooth1D to be consistent with the initial z2exner
       call smooth1D(theta_local(:,j), theta_ref(:))
       exner(:,j)=(rho(:)*Ru*theta_ref(:)/p0)**(r_on_cp/(1.-r_on_cp))
    end do

  end subroutine exner_timestep_upd

end module pressure_update


      INCLUDE 'VICMAIN_FOR'
      SUBROUTINE MAIN44
C     1  MAY 89   ...REA...    INITIAL RELEASE
C     3  DEC 93   ...REA...    Port to Unix
C
	REAL BUF(30000,3)
	INTEGER ISUBAREA(200),INUNIT(3),IOUT(1001,900)
	CHARACTER*80 MSG
	CHARACTER*4 FMT
C
	SQRT3 = SQRT(3.0)
C								open inputs
	DO I=1,3
	    CALL XVUNIT(INUNIT(I),'INP',I,ISTAT,' ')
	    CALL XVOPEN(INUNIT(I),ISTAT,'OPEN_ACT','SA',
     +		        'IO_ACT','SA','U_FORMAT','REAL',' ')
	END DO
C							        get parameters
C								width
	CALL XVPARM('WIDTH',NS,ICNT,IDEF,0)
	NL = NS*SQRT3/2.0 + 0.5
	SAMPOFFSET = (NS+1.0)/2.0 + 0.5
C								format
	CALL XVPARM('FORMAT',FMT,ICNT,IDEF,0)
	IF (FMT.EQ.'BYTE') THEN
	    IBACK = 255
	    MAXVAL = 255
	ELSE
	    IBACK = -1
	    MAXVAL = 32767
	    IF (FMT.EQ.'FULL') MAXVAL=1E9
	END IF
C								area
	CALL XVPARM('AREA',ISUBAREA,N_AREA_PARS,IND,0)
	IF (N_AREA_PARS.EQ.0) THEN
	    N_AREA_PARS = 4
	    ISUBAREA(1) = 1
	    ISUBAREA(2) = 1
	    CALL XVGET(INUNIT(1),ISTAT,'NL',ISUBAREA(3),
     +		       'NS',ISUBAREA(4),' ')
	END IF
C								open output
	CALL XVUNIT(IOUTUNIT,'OUT',1,ISTAT,' ')
	CALL XVOPEN(IOUTUNIT,ISTAT,'U_NL',NL,'U_NS',NS,'U_NB',1,
     +		    'U_ORG','BSQ','OP','WRITE','OPEN_ACT','SA',
     +		    'IO_ACT','SA','O_FORMAT',FMT,'U_FORMAT','FULL',' ')
C
C					      zero output array, fill background
	DO I=1,NL
	    LOW = SAMPOFFSET - (I-1)/SQRT3
	    IHI = SAMPOFFSET + (I-1)/SQRT3
	    DO J=1,LOW-1
		IOUT(J,I) = IBACK
	    END DO
	    DO J=LOW,IHI
		IOUT(J,I) = 0
	    END DO
	    DO J=IHI+1,NS
		IOUT(J,I) = IBACK
	    END DO
	END DO
C					             get the areas to process
	CALL XVMESSAGE(' ',' ')
	CALL XVMESSAGE(' Area(s) Processed:',' ')
	CALL XVMESSAGE(' ',' ')
	DO I=1,N_AREA_PARS,4
	    ISL = ISUBAREA(I)
	    ISS = ISUBAREA(I+1)
	    NLIN = ISUBAREA(I+2)
	    NSIN = ISUBAREA(I+3)
	    WRITE (MSG,100) ISL,ISS,NLIN,NSIN
  100	    FORMAT(I11,3I5)
	    CALL XVMESSAGE(MSG,' ')
C							gather data
	    DO J=1,NLIN
		DO K=1,3
		    CALL XVREAD(INUNIT(K),BUF(1,K),ISTAT,'LINE',J,
     +				'SAMP',ISS,'NSAMPS',NSIN,' ')
		END DO
C
		DO L=1,NSIN
		    X1 = BUF(L,1) + 0.001
		    X2 = BUF(L,2) + 0.001
		    X3 = BUF(L,3) + 0.001
		    ILINE = (1.0-X2/(X1+X2+X3))*(NL-1.0) + 1.5
		    ISAMP = ((X3-X1)*(ILINE-1.0))/((X3+X1)*SQRT3)
     +			    + SAMPOFFSET
		    IOUT(ISAMP,ILINE) = IOUT(ISAMP,ILINE) + 1
		END DO
	    END DO
	END DO
C								write output
	DO I=1,NL
	    DO J=1,NS
		IOUT(J,I) = MIN(IOUT(J,I),MAXVAL)
	    END DO
	    CALL XVWRIT(IOUTUNIT,IOUT(1,I),ISTAT,' ')
	END DO
	RETURN
	END


! Implementation code for vector_analysis module
submodule (vector_analysis) vector_analysis_sm

contains

    ! Calculate the gradient
    module function grad(p, phi) result(r)
        real(8) :: r(3)
        real(8), intent(in) :: p(3)
        procedure(f)        :: phi
        type(auto_var) :: q(3), s
        integer        :: i

        do i=1,3
            call make_var(p, q, i)
            s = phi(q)
            r(i) = s%get_derivative()
        end do

    end function grad

    ! Calculate the divergence
    module function div(p, phi)
        real(8) :: div
        real(8), intent(in) :: p(3)
        procedure(f)        :: phi
        real(8) :: q(3)

        q = grad(p, phi)

        div = sum(q)
    end function div

    !! Calculate the del_squared (== div(grad))
    !module function del_squared(x, y, phi)
    !    real(8) :: del_squared
    !    real(8), intent(in) :: x, y
    !    procedure(f)        :: phi
    !    real(8) :: grad(2)
    !    type(auto_var) :: xa, ya, ra
    !
    !    ! x-component varies, y-component constant
    !    call xa%set(x)
    !    call ya%set_constant(y)
    !    ra = phi(xa, ya)
    !    grad(1) = ra%get_derivative()
    !
    !    ! y-component varies, x-component constant
    !    call xa%set_constant(x)
    !    call ya%set(y)
    !    ra = phi(xa, ya)
    !    grad(2) = ra%get_derivative()
    !
    !    del_squared = sum(grad**2)
    !end function del_squared

    ! This is actually the z-component of curl
    !module function curl(x, y, phi)
    !    real(8) :: curl
    !    real(8), intent(in) :: x, y
    !    procedure(f)        :: phi
    !    real(8) :: grad(2)
    !    type(auto_var) :: xa, ya, ra
    !
    !    ! x-component varies, y-component constant
    !    call xa%set(x)
    !    call ya%set_constant(y)
    !    ra = phi(xa, ya)
    !    grad(1) = ra%get_derivative()
    !
    !    ! y-component varies, x-component constant
    !    call xa%set_constant(x)
    !    call ya%set(y)
    !    ra = phi(xa, ya)
    !    grad(2) = ra%get_derivative()
    !
    !    curl = grad(1) - grad(2)
    !end function curl

    ! Evaluate the given function
    module function evaluate(p, phi)
        real(8) :: evaluate
        real(8), intent(in) :: p(3)
        procedure(f)        :: phi
        type(auto_var) :: q(3), ra
        integer :: i

        ! Make parameters constant - no derivatives
        do i=1,3
            call q(i)%set_constant(p(i))
        end do
        ra = phi(q)
        evaluate = ra%get_value()
    end function evaluate

    ! Cross product of two vectors
    module pure function cross(a, b) result(r)
        real(8), intent(in) :: a(3), b(3)
        real(8) :: r(3)
        integer :: i, j, k

        do i=1,3
            j = merge(1,i+1,i==3)
            k = merge(1,j+1,j==3)
            r(i) = a(j)*b(k)-a(k)*b(j)
        end do
    end function cross

end submodule vector_analysis_sm


       subroutine mgt_tillfactor(jj,bmix,emix,dtil,sol_thick)
	!!!!!!!!!!!!!!!!!!!!!!!
	! Armen 16 January 2008
	! This procedure increases tillage factor (tillagef(l,jj) per layer for each operation
	! The tillage factor settling will depend of soil moisture (tentatively) and must be called every day
	! For simplicity the settling is calculated now at the soil carbon subroutine because soil water content is available

	! The tillage factor depends on the cumulative soil disturbance rating = csdr
	! For simplicity, csdr is a function of emix
	! First step is to calculate "current" csdr by inverting tillage factor function
	! The effect of texture on tillage factor (ZZ) is removed first (and recovered at the end of the procedure)
	! YY = tillagef(l,jj) / ZZ
	! Since the tillage factor function is non linear, iterations are needed
	! XX = 0.5 is the initial value that works OK for the range of values observed
	! If a layer is only partially tilled then emix is corrected accordingly

	use soil_module

    implicit none

	integer, intent (in) :: jj        !none           |HRU number
    real, intent (in) :: bmix         !none           |biological mixing efficiency: this
                                      !               |number is zero for tillage operations
    integer :: l                      !none           |counter
    integer ::m1                      !none           |array location (see definition of ndays)
    integer :: m2                     !               |
    real :: emix                      !none           |mixing efficiency
    real :: dtil                      !mm             |depth of mixing
    real :: XX                        !varies         |variable to hold calculation results
	real :: sol_thick(soil(jj)%nly)   !               |
    integer :: j                      !none           |counter
    real :: zz                        !               |
    real :: yy                        !               |
    real :: xx1                       !               |
    real :: xx2                       !               |
    real :: csdr                      !               |

	emix = emix - bmix ! this is to avoid affecting tillage factor with biological mixing

	if (emix > 0.) then

	  do l = 1, soil(j)%nly

	    if (soil(jj)%phys(l)%d <= dtil) then
		  emix = emix
          else if(soil(jj)%phys(l)%d > dtil .AND. soil(jj)%phys(l-1)%d    &
                 < dtil) then
		emix = emix * (dtil - soil(jj)%phys(l-1)%d) / sol_thick(l)
	    else
		emix = 0.
	    end if

	    ! to save computation time if emix = 0 here then the other layers can be avoided
	    ! tillage always proceeds from top to bottom
	    if (emix == 0.) exit

	    xx = 0.
	    zz = 3. + (8. - 3.)*exp(-5.5*soil(jj)%phys(1)%clay/100.)
	    yy = soil(jj)%ly(l)%tillagef / zz
	    m1 = 1
	    m2 = 2

	    ! empirical solution for x when y is known and y=x/(x+exp(m1-m2*x))
	    if (yy > 0.01) then
		 xx1 = yy ** exp(-0.13 + 1.06 * yy)
		 xx2 = exp(0.64 + 0.64 * yy ** 100.)
		 xx = xx1 * xx2
	    end if

	    csdr = xx + emix
	    soil(jj)%ly(l)%tillagef = zz * (csdr / (csdr + exp(m1 - m2*csdr)))

	  end do

	end if

	return
	end subroutine mgt_tillfactor


! = = = = = = = = = = = = = = = = = = = = = = =
!
!  This SUBROUTINE calculates the PA relationship
!
! = = = = = = = = = = = = = = = = = = = = = = =

#include "AMYCAI.h"

SUBROUTINE QA_RELATION

! parameter AND array modules

    USE FloatPrecision
    USE TimeCatcher
    USE ArraySize
    USE Grids
    USE Hydro
    USE Topography
    USE Parameters

! Routine modules

    USE Longitudinal_1D_Model

    IMPLICIT NONE

! Define the Pointers to the surface AND
! discharge array for 1D Longitudinal model

    REAL(fp) , DIMENSION(:)   , POINTER :: QQ1 , QQ2
    REAL(fp) , DIMENSION(:)   , POINTER :: EE1 , EE2 , DEE1

    REAL(fp) , ALLOCATABLE , DIMENSION(:,:) :: TD_Prism
    REAL(fp) , ALLOCATABLE , DIMENSION(:,:) :: Steady_Area

    REAL(fp)                          :: MAXH, aa1, CC
    REAL                              :: TT1, TT2, TTC
    INTEGER                           :: status , I , J , FID , FID0
    CHARACTER(len=100)                 :: FILENAME
    CHARACTER(len=80)                 :: DIRECTION
    CHARACTER(len=80)                 :: err_msg

    NULLIFY(QQ1,QQ2,EE1,EE2,DEE1)

! CPU Timer : begin

    CALL CPU_TIME(TT1)

! - - - - - - - - - - -
!
! Initialize parameters
!
! - - - - - - - - - - -
    BT = DBLE(NU-NL)*dx
    LU = DBLE(MU-ML)*dy
    T0 = 0.5D0*TDCYC   ! start from low tide
    IT0   = 0
    IHOUR = 0
    IDAY  = 0
    IYEAR = 0
    IDT   = INT(DT)
    CD    = 0
    CD2   = 0
    FID0 = 0

    Q_RESIDUAL1(:) = 0.D0
    Q_RESIDUAL2(:) = 0.D0

! ALLOCATE

    ALLOCATE(TD_Prism(ML:MU,1:File_Number),stat=status,errmsg=err_msg)
    ALLOCATE(Steady_Area(ML:MU,1:File_Number),stat=status,errmsg=err_msg)

! TARGET READY

    ETA1(:) = 0.D0
    ETA2(:) = 0.D0
    Q1(:) = 0.D0
    Q2(:) = 0.D0
    HETA(:) = 0.D0
    Q_RESIDUAL1(:) = 0.D0
    Q_RESIDUAL2(:) = 0.D0
    TDEP0 = 0.D0
    TD_Prism(:,:) = 0.D0
    Steady_Area(:,:) = 0.D0

!POINTER READY

    QQ1=>Q1
    QQ2=>Q2
    EE1=>ETA1
    EE2=>ETA2
    DEE1=>DETA1
!= = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!       Calculate the PA relationship
!
!= = = = = = = = = = = = = = = = = = = = = = = = = = = = =

! initialize the tidal amp

    TDAMP = TDAMP0

    DIRECTION = 'c:\tidal_channel_q2d_model_xf\Q2D_Model_2_longitudinal\XUFAN_QUASI_2D_model\'
    WRITE(*,*) File_Number
    pause
    LPF: DO FID = Start_File_ID , End_File_ID , File_ID_FRQ

        FID0 = FID0 + 1

        WRITE(*,*) 'FILE_ID = ' , FID , FID0
        WRITE(FILENAME,'(A76,A4,I6.6,A4)') TRIM(DIRECTION),'Dep_',FID,'.RES'
        OPEN(UNIT=10,FILE=FILENAME,FORM='UNFORMATTED',STATUS='OLD',IOSTAT=status,ACTION='READ')
        READ(10) DEP0
        CLOSE(0)

!- - - - - - - - - - - - - - - - - - - - - - - - - - -
!   Calculate the Area
!- - - - - - - - - - - - - - - - - - - - - - - - - - -

        DO I = ML , MU
            aa1 = 0.d0
            do J = NL , NU-1
                if(DEP0(I,J)>0.d0.and.DEP0(I,J+1)>0.d0) then
                    aa1 = aa1 + 0.5d0*dx*(DEP0(I,J)+DEP0(I,J+1))
                elseif(DEP0(I,J)>0.d0.and.DEP0(I,J+1)<=0.d0) then
                    CC = DEP0(I,J) / (DEP0(I,J) - DEP0(I,J+1))
                    aa1 = aa1 + 0.5d0*dx*DEP0(I,J)*CC
                elseif(DEP0(I,J)<=0.d0.and.DEP0(I,J+1)>0.d0) then
                    CC = DEP0(I,J+1) / (DEP0(I,J+1) - DEP0(I,J))
                    aa1 = aa1 + 0.5d0*dx*DEP0(I,J+1)*CC
                end if
            end do
            Steady_Area(I,FID0) = aa1*2.D0
#ifndef TIDE_OSCILLATION
            !Steady_Area(I,FID0) = Steady_Area(I,FID0) - 0.05D0*BT
#endif
        END DO

        LPT:DO

!- - - - - - - - - - - - - - - - - - - - - - - - - - -
!   Time variation
!- - - - - - - - - - - - - - - - - - - - - - - - - - -

            T0 = T0 + DT

!- - - - - - - - - - - - - - - - - - - - - - - - - - -
!   Longitudinal 1D model, calculate discharge Q
!   , surface elevation eta AND cross-section area
!- - - - - - - - - - - - - - - - - - - - - - - - - - -
#ifdef TIDE_OSCILLATION
            CALL Water_Continuity_Model(EE1,DEE1,DEP0,T0,TDEP0,QQ1,BC,AC)
#else
            DO  I  = ML , MU
                QQ1(I) = DBLE(MU-I)/DBLE(MU-ML)*Q_CONST
            END DO
#endif
!- - - - - - - - - - - - - - - - - - - - - - - - - - -
!   Calculate the tidal prism
!- - - - - - - - - - - - - - - - - - - - - - - - - - -

            TD_Prism(:,FID0) = TD_Prism(:,FID0) + QQ1(:)*dt*2.D0

!- - - - - - - - - - - - - - - - - - - - - - - - - - -
! reaching the high tide , exit
!- - - - - - - - - - - - - - - - - - - - - - - - - - -

            IF(T0>=TDCYC) THEN
                T0 = 0.5D0*TDCYC
                EXIT LPT
            END IF

        END DO LPT
    END DO LPF

!= = = = = = = = = = = = = = = = = = = = = = = = = = = = =

! OUTPUT

    OPEN(UNIT=10,FILE=TRIM(DIRECTION)//'Prism2.RES',FORM='UNFORMATTED',STATUS='REPLACE',IOSTAT=status,ACTION='WRITE')
    WRITE(10) TD_Prism
    CLOSE(10)

    OPEN(UNIT=10,FILE=TRIM(DIRECTION)//'Area2.RES',FORM='UNFORMATTED',STATUS='REPLACE',IOSTAT=status,ACTION='WRITE')
    WRITE(10) Steady_Area
    CLOSE(10)

    DEALLOCATE(TD_Prism,stat=status,errmsg=err_msg)
    DEALLOCATE(Steady_Area,stat=status,errmsg=err_msg)

! CPU Timer : END

    CALL CPU_TIME(TT2)
    WRITE(*,101) (TT2-TT1)/60.
    PAUSE

101 FORMAT("The simulation costs ",f5.1," minuts")
102 FORMAT("DAY = ",I5)

END SUBROUTINE QA_RELATION


subroutine CalcFreestream(xElem,yElem,zElem,u,v,w,ygcErr)

    use shear
    use configr
    use iecgust
    use tower

    real u, v, w
    real xElem,yElem,zElem
    integer ygcErr

    real IECGustVel, Vxtower

    ! Freestream velocity (with ground shear model)
    ! At y/R = 0, u/Uinf = 0. At y/R = yref, u/Uinf = 1
    ! slex = 0 : Constant freestream
    ! slex = 1/2 : Laminar shear layer (approx)
    ! slex = 1/7 : Turbulent shear layer (approx)

    if (Igust .EQ. 1) then
        u = IECGustVel((nt-1)*dt,xElem)
        v = 0.0
        w = 0.0
        !Write(*,'(F15.8)') u
        return
    end if

    if ((yElem+ygc) <= 0.0) then
        ! reflect across zero...
        ygcErr=1
        u=(-(yElem+ygc)/yref)**slex
        u=max(u,.01)  ! limit to some non zero value...
        v=0.0
        w=0.0
    else
        u=((yElem+ygc)/yref)**slex
        u=max(u,.01)  ! limit to some non zero value...
        v=0.0
        w=0.0
    end if

    if (Itower .EQ. 1) then
       Vxtower = wake_defect_velocity(xElem,yElem,zElem)
       !Write(20,'(4F20.12)') xElem,yElem,zElem,Vxtower
       u = u - Vxtower
       u = max(u,.01)
       !If (Vxtower .GT. .001) Write(20,'(F20.12)') u+Vxtower, u
    end if

    return
end subroutine CalcFreestream

REAL FUNCTION IECGustVel(time,x)

    Use iecgust
    Use pidef

    real time, x

    real tr

    tr = time - x - gustX0

    if ((tr .LE. gustT) .AND. (tr .GT. 0)) then
        IECGustVel = 1.0 - 0.37 * gustA * sin(3*pi*tr/gustT) &
            * (1.0 - cos(2*pi*tr/gustT))
        !Write(*,'(2F20.12)') tr,IECGustVel
    else
        IECGustVel = 1.0
    end if

    return

End FUNCTION IECGustVel


c subroutine legfit.f
c
c source
c   Bevington, pages 155-157.
c
c purpose
c   make a least-squares fit to data with a legendre polynomial
c      y = a(1) + a(2)*x + a(3)*(3x**2-1)/2 + ...
c        = a(1) * (1. + b(2)*x + b(3)*(3x**2-1)/2 + ... )
c      where x = cos(theta)
c
c usage
c   call legfit (theta, y, sigmay, npts, norder, neven, mode, ftest,
c      yfit, a, sigmaa, b, sigmab, chisqr)
c
c description of parameters
c   theta  - array of angles (in degrees) of the data points
c   y      - array of data points for dependent variable
c   sigmay - array of standard deivations for y data points
c   npts   - number of pairs of data points
c   norder - highest order of polynomial (number of terms - 1)
c   neven  - determines odd or even character of polynomial
c            +1 fits only to even terms
c             0 fits to all terms
c            -1 fits only to odd terms (plus constant term)
c   mode   - determines mode of weighting least-squares fit
c            +1 (instrumental) weight(i) = 1./sigmay(i)**2
c             0 (no weighting) weight(i) = 1.
c            -1 (statistical)  weight(i) = 1./y(i)
c   ftest  - array of values of f(l) for an f test
c   yfit   - array of calculated values of y
c   a      - array of coefficients of polynomial
c   sigmaa - array of standard deviations for coefficients
c   b      - array of normalized relative coefficients
c   sigmab - array of standard deviations for relative coefficients
c   chisqr - reduced chi square for fit
c
c subroutines and function subprograms required
c   matinv (array, nterms, det)
c      inverts a symmetric two-dimensional matrix of degree nterms
c      and calculates its determinant
c
c comments
c   dimension statement valid for npts up to 100 and order up to 9
c   dcos changed to cos in statement 31
c
      subroutine legfit (theta,y,sigmay,npts,norder,neven,mode,
     *ftest,yfit,a,sigmaa,b,sigmab,chisqr)
      double precision cosine,p,beta,alpha,chisq
      dimension theta(1),y(1),sigmay(1),ftest(1),yfit(1),
     *a(1),sigmaa(1),b(1),sigmab(1)
      dimension weight(100),p(100,10),beta(10),alpha(10,10)
c
c accumulate weights and legendre polynomials
c
11    nterms=1
      ncoeff=1
      jmax=norder+1
20    do 40 i=1,npts
21    if (mode) 22,27,29
22    if (y(i)) 25,27,23
23    weight(i)=1./y(i)
      goto 31
25    weight(i)=1./(-y(i))
      goto 31
27    weight(i)=1.
      goto 31
29    weight(i)=1./sigmay(i)**2
31    cosine=cos(0.01745329252*theta(i))
      p(i,1)=1.
      p(i,2)=cosine
      do 36 l=2,norder
      fl=l
36    p(i,l+1)=((2.*fl-1.)*cosine*p(i,l)-(fl-1.)*p(i,l-1))/fl
40    continue
c
c accumulate matrices alpha and beta
c
51    do 54 j=1,nterms
      beta(j)=0.
      do 54 k=1,nterms
54    alpha(j,k)=0.
61    do 66 i=1,npts
      do 66 j=1,nterms
      beta(j)=beta(j)+p(i,j)*y(i)*weight(i)
      do 66 k=j,nterms
      alpha(j,k)=alpha(j,k)+p(i,j)*p(i,k)*weight(i)
66    alpha(k,j)=alpha(j,k)
c
c delete fixed coefficients
c
70    if (neven) 71,91,81
71    do 76 j=3,nterms,2
      beta(j)=0.
      do 75 k=1,nterms
      alpha(j,k)=0.
75    alpha(k,j)=0.
76    alpha(j,j)=1.
      goto 91
81    do 86 j=2,nterms,2
      beta(j)=0.
      do 85 k=1,nterms
      alpha(j,k)=0.
85    alpha(k,j)=0.
86    alpha(j,j)=1.
c
c invert curvature matrix alpha
c
91    do 95 j=1,jmax
      a(j)=0.
      sigmaa(j)=0.
      b(j)=0.
95    sigmab(j)=0.
      do 97 i=1,npts
97    yfit(i)=0.
101   call matinv (alpha,nterms,det)
      if (det) 111,103,111
103   chisqr=0.
      goto 170
c
c calculate coefficients, fit, and chi square
c
111   do 115 j=1,nterms
      do 113 k=1,nterms
113   a(j)=a(j)+beta(k)*alpha(j,k)
      do 115 i=1,npts
115   yfit(i)=yfit(i)+a(j)*p(i,j)
121   chisq=0.
      do 123 i=1,npts
123   chisq=chisq+(y(i)-yfit(i))**2*weight(i)
      free=npts-ncoeff
      chisqr=chisq/free
c
c test for end of fit
c
131   if (nterms-jmax) 132,151,151
132   if (ncoeff-2) 133,134,141
133   if (neven) 137,137,135
134   if (neven) 135,137,135
135   nterms=nterms+2
      goto 138
137   nterms=nterms+1
138   ncoeff=ncoeff+1
      chisq1=chisq
      goto 51
141   fvalue=(chisq1-chisq)/chisqr
      if (ftest(nterms)-fvalue) 134,143,143
143   if (neven) 144,146,144
144   nterms=nterms-2
      goto 147
146   nterms=nterms-1
147   ncoeff=ncoeff-1
      jmax=nterms
149   goto 51
c
c calculate remainder of output
c
151   if (mode) 152,154,152
152   varnce=1.
      goto 155
154   varnce=chisqr
155   do 156 j=1,nterms
156   sigmaa(j)=dsqrt(varnce*alpha(j,j))
161   if (a(1)) 162,170,162
162   do 166 j=2,nterms
      if (a(j)) 164,166,164
164   b(j)=a(j)/a(1)
165   sigmab(j)=b(j)*dsqrt((sigmaa(j)/a(j))**2+(sigmaa(1)/a(1))**2
     *-2.*varnce*alpha(j,1)/(a(j)*a(1)))
166   continue
      b(1)=1.
170   return
      end


      SUBROUTINE EKSC (S,Z,RH,XK,IJ,EZS,ERS,EZC,ERC,EZK,ERK)
C     COMPUTE E FIELD OF SINE, COSINE, AND CONSTANT CURRENT FILAMENTS BY
C     THIN WIRE APPROXIMATION.
      COMPLEX CON,GZ1,GZ2,GP1,GP2,GZP1,GZP2,EZS,ERS,EZC,ERC,EZK,ERK
      COMMON /TMI/ ZPK,RKB2,IJX
      DIMENSION CONX(2)
      EQUIVALENCE (CONX,CON)
      DATA CONX/0.,4.771341189/
      IJX=IJ
      ZPK=XK*Z
      RHK=XK*RH
      RKB2=RHK*RHK
      SH=.5*S
      SHK=XK*SH
      SS=SIN(SHK)
      CS=COS(SHK)
      Z2=SH-Z
      Z1=-(SH+Z)
      CALL GX (Z1,RH,XK,GZ1,GP1)
      CALL GX (Z2,RH,XK,GZ2,GP2)
      GZP1=GP1*Z1
      GZP2=GP2*Z2
      EZS=CON*((GZ2-GZ1)*CS*XK-(GZP2+GZP1)*SS)
      EZC=-CON*((GZ2+GZ1)*SS*XK+(GZP2-GZP1)*CS)
      ERK=CON*(GP2-GP1)*RH
      CALL INTX (-SHK,SHK,RHK,IJ,CINT,SINT)
      EZK=-CON*(GZP2-GZP1+XK*XK*DCMPLX(CINT,-SINT))
      GZP1=GZP1*Z1
      GZP2=GZP2*Z2
      IF (RH.LT.1.E-10) GO TO 1
      ERS=-CON*((GZP2+GZP1+GZ2+GZ1)*SS-(Z2*GZ2-Z1*GZ1)*CS*XK)/RH
      ERC=-CON*((GZP2-GZP1+GZ2-GZ1)*CS+(Z2*GZ2+Z1*GZ1)*SS*XK)/RH
      RETURN
1     ERS=(0.,0.)
      ERC=(0.,0.)
      RETURN
      END


!>
module UIVortexCylinders
    use PrecisionMod, only: MK
    implicit none

    real(MK),parameter :: MINNORM=1e-4
contains

    !> Semi Infinite vortex cylinder with tangential vorticiy
    subroutine fUi_VortexCylinderTangSemiInf_11(CP,PCenter,R,gamma_t,N, SmoothModel,SmoothParam,bComputeGrad,Uind,Grad)
        ! Arguments declarations
        real(MK), dimension(3), intent(in)    :: CP           !<
        real(MK), dimension(3), intent(in)    :: PCenter      !< PCenter : Position of ring center
        real(MK), intent(in)                  :: R            !< Cylinder radius
        real(MK), intent(in)                  :: gamma_t      !< Tangential vorticity Intensity
        real(MK), dimension(3), intent(in)    :: N            !< Vector norm is gamma_t, direction is normal to the
        integer, intent(in)                   :: SmoothModel  !<
        real(MK), intent(in)                  :: SmoothParam  !<
        logical, intent(in)                   :: bComputeGrad !<
        real(MK), dimension(3), intent(inout) :: Uind         !< side effects
        real(MK), dimension(9), intent(inout) :: Grad         !< side effects
        ! Variable declarations
        real(MK), dimension(3) :: ex  !<
        real(MK), dimension(3) :: ey  !<
        real(MK), dimension(3) :: ez  !<
        real(MK), dimension(3,3) :: T_r2g
        real(MK), dimension(3,3) :: T_g2r
        integer :: imin
        real(MK), dimension(3) :: CP_loc  !<
        real(MK) :: R_cp
        real(MK) :: Z_cp
        real(MK) :: phi
        real(MK), dimension(3) :: Uindtmp         !<
        real(MK), dimension(9) :: Gradtmp         !<
        real(MK) :: urad
        real(MK) :: upsi
        !         ! Note: theories return only vr (index 1) and vz (index 3), there is some cartesian handling though, but does it work ? Is it consistent with the rest of the codes. Does it make use of the inputed vpsi to reduce the error in the angle estimate.
        !
        !! Setting up an orthonornal cartesian system normal to the ring
        ez(1:3)=N(1:3)/norm2(N) ! just in case N is not unitary
        imin=minloc(abs(ez),1)
        ey=ez
        ey(imin)=0
        ey=ey([ 2,3,1 ] )
        ey(imin)=-ey(imin)
        ey=ey/norm2(ey)
        ex=cross(ey,ez)
!         print*,ex
!         print*,ey
!         print*,ez
        !! Now setting up rotation matrix
        T_r2g(1:3,1)=ex(1:3)
        T_r2g(1:3,2)=ey(1:3)
        T_r2g(1:3,3)=ez(1:3)
        T_g2r=transpose(T_r2g)

        !! Coordinate transformation to a cartesian frame normal to the ring
        CP_loc(1)=T_g2r(1,1)*(CP(1)-PCenter(1)) + T_g2r(1,2)*(CP(2)-PCenter(2)) + T_g2r(1,3)*(CP(3)-PCenter(3))
        CP_loc(2)=T_g2r(2,1)*(CP(1)-PCenter(1)) + T_g2r(2,2)*(CP(2)-PCenter(2)) + T_g2r(2,3)*(CP(3)-PCenter(3))
        CP_loc(3)=T_g2r(3,1)*(CP(1)-PCenter(1)) + T_g2r(3,2)*(CP(2)-PCenter(2)) + T_g2r(3,3)*(CP(3)-PCenter(3))

        !! Coordinate transform to a canonical polar coordinates
        Z_cp=CP_loc(3) ! Since we are already in the ring coordinate system
        R_cp=sqrt(CP_loc(1)**2+CP_loc(2)**2)
        !print*,'CP_loc',CP_loc

        !! Computing velocity in polar coordinates
        Uindtmp=0.0_MK
        Gradtmp=0.0_MK
        !print*,'gamma_t',gamma_t
        ! We use the Smooth Param of the cylinder no matter the SmoothModel
        if(SmoothModel==0) then
            call fUi_CylinderTangSemiInf11_loc(R_cp, Z_cp, gamma_t, R, SmoothParam, Uindtmp)
            !print*,'Uind pol',Uindtmp
        else
            call fUi_CylinderTangSemiInf11_loc(R_cp, Z_cp, gamma_t, R, SmoothParam, Uindtmp)
        endif

        !! Converting to cartesian
        phi=atan2(CP_loc(2),CP_loc(1))
        !print*,'phi',phi*180/3.141593
        urad=Uindtmp(1)
        upsi=0.0_MK
        Uindtmp(1)=+urad*cos(phi)
        Uindtmp(2)=+urad*sin(phi)
        !print*,'Uind cart',Uindtmp

        !! Going back to global frame
        Uind(1)=Uind(1) + T_r2g(1,1)*Uindtmp(1) + T_r2g(1,2)*Uindtmp(2) + T_r2g(1,3)*Uindtmp(3)
        Uind(2)=Uind(2) + T_r2g(2,1)*Uindtmp(1) + T_r2g(2,2)*Uindtmp(2) + T_r2g(2,3)*Uindtmp(3)
        Uind(3)=Uind(3) + T_r2g(3,1)*Uindtmp(1) + T_r2g(3,2)*Uindtmp(2) + T_r2g(3,3)*Uindtmp(3)

        !print*,'Uind glob',Uind
        !! TODO gradient
        if (bComputeGrad) then
            Grad = 0.0D0
        else
            Grad = 0.0D0
        end if
    contains
        !> Cross product of two vectors ! See crossprod in UTILS...
        function cross(a, b)
            real(MK), dimension(3) :: cross
            real(MK), dimension(3), intent(in) :: a, b
            cross(1) = a(2) * b(3) - a(3) * b(2)
            cross(2) = a(3) * b(1) - a(1) * b(3)
            cross(3) = a(1) * b(2) - a(2) * b(1)
        end function cross
    end subroutine

    !> Induction from a Cylinder at a control point, within the referential of a Cylinder: coordinates (r,theta, z), the ring is at z=0
    subroutine fUi_CylinderTangSemiInf11_loc(Rcp, Zcp, gamma_t, R, SmoothParam, Uind)
        use EllipticIntegrals, only: elliptic_ke, elliptic_pi
        use MathConstants, only:  pi
        ! Arguments declarations
        real(MK), intent(in) :: Rcp   !< Control point radius
        real(MK), intent(in) :: Zcp   !< Control point z location
        real(MK), intent(in) :: gamma_t !< Cylinder intensity
        real(MK), intent(in) :: R     !< Cylinder radius
        real(MK), intent(in) :: SmoothParam  !<
        real(MK), dimension(3), intent(inout) :: Uind  !< side effects, in coord (r, theta, z)
        ! Variable declarations
        real(MK), parameter :: MIN_DIST=1e-7 ! threshold for using axis formula
        real(MK) :: KK  !<
        real(MK) :: EE  !<
        real(MK) :: PPI  !<
        real(MK) :: k  !<
        real(MK) :: k_2  !<
        real(MK) :: k0_2  !<

        if (rcp<MIN_DIST*R) then
            !! Using Axis formula : v_z=-Gamma/(2R) *1 / (1+(z/R)^2)^(3/2) See Naca 1184 - Watsle, or Glauert Contraction of slipstream of an airscrew 1926
            Uind(1)=0
            Uind(3)=gamma_t/(2_MK)*(1_MK + Zcp/sqrt(Zcp**2+R**2))
        else
            ! Eliptic integrals
            k_2 = 4_MK*rcp*R/((R+rcp)**2+zcp**2+SmoothParam**2)
            k = sqrt(k_2)
            k0_2 = 4_MK*rcp*R/((R+rcp)**2+SmoothParam**2)
            call elliptic_ke( k_2 , KK,EE)
            call elliptic_pi(k0_2,90._MK,k_2,PPI)
            ! ur
            Uind(1)=-gamma_t/(2_MK*pi)*sqrt(R/rcp)*( (2_MK-k_2)/k*KK - 2_MK/k*EE )
            ! ur
            Uind(3)= gamma_t/2_MK*( 1._MK/2._MK*(1+(R-rcp)/((rcp+R)*sqrt(1-k0_2))) &
                +zcp*k/(2_MK*pi*sqrt(rcp*R))*(KK + (R-rcp)/(R+rcp)*PPI ) )
        endif
    end subroutine fUi_CylinderTangSemiInf11_loc

    subroutine fui_cylinder11_loc_c(Rcp, Zcp, gamma_t, R,SmoothParam, Uind) bind(C,name='fui_cylinder11_loc_c')
        use PrecisionMod, only: C_DOUBLE
        !DEC$ ATTRIBUTES DLLEXPORT :: fui_cylinder11_loc_c
        !GCC$ ATTRIBUTES DLLEXPORT :: fui_cylinder11_loc_c
        ! Arguments declarations
        real(C_DOUBLE), intent(in) :: Rcp   !< Control point radius
        real(C_DOUBLE), intent(in) :: Zcp   !< Control point z location
        real(C_DOUBLE), intent(in) :: gamma_t !< cylinder intensity
        real(C_DOUBLE), intent(in) :: R     !< cylinder radius
        real(C_DOUBLE), intent(in) :: SmoothParam     !< cylinder radius
        real(C_DOUBLE), dimension(3), intent(inout) :: Uind  !< side effects, in coord (r, theta, z)
        real(MK), dimension(3) :: Uind_MK

        Uind_MK=0.0_MK
        call fUi_CylinderTangSemiInf11_loc(Rcp, Zcp, gamma_t, R, SmoothParam, Uind_MK)
        Uind=real(Uind_MK,C_DOUBLE)

    end subroutine

end module


Subroutine rfx_lqg_observe( n_x, n_u, n_z, A, B, C, x, u, z, K, dx, zwork )
  Implicit None
  integer, intent(in) :: n_x, n_u, n_z                  ! state/input space
  real(8), intent(in), dimension(n_x) :: x
  real(8), intent(in), dimension(n_u) :: u
  real(8), intent(in), dimension(n_z) :: z
  real(8), intent(in), dimension(n_x,n_x) :: A
  real(8), intent(in), dimension(n_x,n_u) :: B
  real(8), intent(in), dimension(n_z,n_x) :: C
  real(8), intent(in), dimension(n_x,n_z) :: K
  real(8), intent(out), dimension(n_x) :: dx
  real(8), intent(out), dimension(n_z) :: zwork
  !! dx = A*x + B*u + K*(z-C*x)
  !! gfortran is pretty dumb

  !dx = matmul(A,x)
  !dx = dx + matmul(B,u)
  !zwork = matmul(C,x)
  !zwork = z - zwork

  dx = matmul(A,x) + matmul(B,u) + matmul(K, z - matmul(C,x))
End Subroutine rfx_lqg_observe


#version 330 core
out vec4 color;

//  Simplex 3D Noise
//  by Ian McEwan, Ashima Arts
//
vec4 permute(vec4 x){return mod(((x*34.0)+1.0)*x, 289.0);}
vec4 taylorInvSqrt(vec4 r){return 1.79284291400159 - 0.85373472095314 * r;}

float snoise(vec3 v){
  const vec2  C = vec2(1.0/6.0, 1.0/3.0) ;
  const vec4  D = vec4(0.0, 0.5, 1.0, 2.0);

// First corner
  vec3 i  = floor(v + dot(v, C.yyy) );
  vec3 x0 =   v - i + dot(i, C.xxx) ;

// Other corners
  vec3 g = step(x0.yzx, x0.xyz);
  vec3 l = 1.0 - g;
  vec3 i1 = min( g.xyz, l.zxy );
  vec3 i2 = max( g.xyz, l.zxy );

  //  x0 = x0 - 0. + 0.0 * C
  vec3 x1 = x0 - i1 + 1.0 * C.xxx;
  vec3 x2 = x0 - i2 + 2.0 * C.xxx;
  vec3 x3 = x0 - 1. + 3.0 * C.xxx;

// Permutations
  i = mod(i, 289.0 );
  vec4 p = permute( permute( permute(
             i.z + vec4(0.0, i1.z, i2.z, 1.0 ))
           + i.y + vec4(0.0, i1.y, i2.y, 1.0 ))
           + i.x + vec4(0.0, i1.x, i2.x, 1.0 ));

// Gradients
// ( N*N points uniformly over a square, mapped onto an octahedron.)
  float n_ = 1.0/7.0; // N=7
  vec3  ns = n_ * D.wyz - D.xzx;

  vec4 j = p - 49.0 * floor(p * ns.z *ns.z);  //  mod(p,N*N)

  vec4 x_ = floor(j * ns.z);
  vec4 y_ = floor(j - 7.0 * x_ );    // mod(j,N)

  vec4 x = x_ *ns.x + ns.yyyy;
  vec4 y = y_ *ns.x + ns.yyyy;
  vec4 h = 1.0 - abs(x) - abs(y);

  vec4 b0 = vec4( x.xy, y.xy );
  vec4 b1 = vec4( x.zw, y.zw );

  vec4 s0 = floor(b0)*2.0 + 1.0;
  vec4 s1 = floor(b1)*2.0 + 1.0;
  vec4 sh = -step(h, vec4(0.0));

  vec4 a0 = b0.xzyw + s0.xzyw*sh.xxyy ;
  vec4 a1 = b1.xzyw + s1.xzyw*sh.zzww ;

  vec3 p0 = vec3(a0.xy,h.x);
  vec3 p1 = vec3(a0.zw,h.y);
  vec3 p2 = vec3(a1.xy,h.z);
  vec3 p3 = vec3(a1.zw,h.w);

//Normalise gradients
  vec4 norm = taylorInvSqrt(vec4(dot(p0,p0), dot(p1,p1), dot(p2, p2), dot(p3,p3)));
  p0 *= norm.x;
  p1 *= norm.y;
  p2 *= norm.z;
  p3 *= norm.w;

// Mix final noise value
  vec4 m = max(0.6 - vec4(dot(x0,x0), dot(x1,x1), dot(x2,x2), dot(x3,x3)), 0.0);
  m = m * m;
  return 42.0 * dot( m*m, vec4( dot(p0,x0), dot(p1,x1),
                                dot(p2,x2), dot(p3,x3) ) );
}

const vec3 white		=	vec3(1.0,1.0,1.0);
const vec3 firstColor	=	vec3(1.0,0.6,0.0);
const vec3 secondColor	=	vec3(1.0,0.0,0.0);

uniform int resolution;
uniform float time;
uniform float scale;

float smoothThing(vec3 x, int octave, float persistence, float scale, float low, float high)
{
	float maxAmp = 0;
	float amp = 1;
	float freq = scale;
	float noise = 0;
	for (int i = 0; i<octave; i++)
	{
		noise += snoise(x*freq) * amp;
		maxAmp += amp;
		amp *= persistence;
		freq *= 2;
	}

	noise /= maxAmp;
	noise = noise * (high - low) / 2 + (high + low) / 2;

	return noise;
}

void main()
{
	float noise = smoothThing(vec3(gl_FragCoord.xy,time),resolution, 0.7, scale, 0, 1);

	vec3 tempColor = mix(white, firstColor, smoothstep(0.1, 0.9, noise));
	tempColor = mix(tempColor, secondColor, smoothstep(0.5, 0.75, noise));
	//tempColor = mix(tempColor, green, smoothstep(0.75, 1, noise));

	color = vec4(tempColor,1.0);
};


subroutine WSolnSetup()

    use util
    use wallsoln
    use wallsystem
!$  use omp_lib

    integer :: i, j, Self, IBCInd, BCRow
    integer :: INFO
    integer, allocatable :: IPIV(:)
    real :: R(3,3), Point(3), dPG(3), dVel(3), dVelG(3), dudx

    real :: t0,t1 ! cpu time variables for matrix inversion

    ! Set up ground plane system
    if (GPFlag==1) then

        !! This assumes WGeomSetup() has already been called, and that the ground plane has been configured
        !  as a wall system of one wall.

        ! Setup wall self influence matrix
        write(*,*) 'Generating wall influence matrix...'
        call cpu_time(t0)
!$      t0 = omp_get_wtime()
        call gen_influence_matrix()
        call cpu_time(t1)
!$      t1 = omp_get_wtime()
        print '("Time to generate influence matrix = ",f15.3," seconds.")',t1-t0

        ! Store wall solution matrix and inverse
        write(*,*) 'Inverting wall influence matrix...'
        call cpu_time(t0)
!$      t0 = omp_get_wtime()
        call invert_influence_matrix()
        call cpu_time(t1)
!$      t1 = omp_get_wtime()
        print '("Time to invert influence matrix = ",f15.3," seconds.")',t1-t0

    end if

    ! Set up generic wall system
    if (WPFlag==1) then

        !! This assumes that the wall geometry has already been loaded as a wall system of one wall.

        ! Setup wall self influence matrix
        write(*,*) 'Generating wall influence matrix...'
        call cpu_time(t0)
!$      t0 = omp_get_wtime()
        call gen_influence_matrix()
        call cpu_time(t1)
!$      t1 = omp_get_wtime()
        print '("Time to generate influence matrix = ",f15.3," seconds.")',t1-t0

        ! Store wall solution matrix and inverse
        write(*,*) 'Inverting wall influence matrix...'
        call cpu_time(t0)
!$      t0 = omp_get_wtime()
        call invert_influence_matrix()
        call cpu_time(t1)
!$      t1 = omp_get_wtime()
        print '("Time to invert influence matrix = ",f15.3," seconds.")',t1-t0

    end if

    ! Set up free surface system
    if (FSFlag==1) then

        ! Setup free surface self influence matrix
        do i=1,NumFSP
            do j=1,NumFSCP
                ! Rotation from global to panel i
                R(1,1:3)=FSXVec(i,1:3)
                R(2,1:3)=FSYVec(i,1:3)
                R(3,1:3)=FSZVec(i,1:3)

                ! Calc influence in panel frame
                dPG=FSCPPoints(j,1:3)-FSCPoints(i,1:3)
                Call CalcRotation3(R,dPG,Point,0)
                Call RectSourceVel(Point,FSPL(i),FSPW(i),1.0,0,FSEdgeTol,1,dVel,dudx)

                ! Rotate to global frame
                Call CalcRotation3(R,dVel,dVelG,1)
                FSInCoeffN(j,i)=sum(dVelG*FSCZVec(j,1:3))
                FSInCoeffT(j,i)=sum(dVelG*FSCXVec(j,1:3))
                FSInCoeffdUdX(j,i)=dudx
            end do
        end do

        ! Create free surface solution matrix and inverse
        if (UseFSWall) then
            ! Wall solution matrix
            FSSMat=FSInCoeffN
        else
            ! Free surface solution matrix
            FSSMat(1:NumFSCP,1:NumFSP)=FSInCoeffN-(FnR**2)*FSInCoeffdUdX
            ! Add inflow BCs
            FSBCRow(:)=0
            do i=1,NumFSCPz
                IBCInd=1+(i-1)*NumFSCPx
                BCRow=NumFSCP+i
                FSSMat(BCRow,1:NumFSP)=FSInCoeffdUdX(IBCInd,1:NumFSP)
                ! Set BC row index
                FSBCRow(IBCInd)=BCRow
            end do
        end if

        ! LAPACK => DGESV: Linear equation solution A*X=B where A(N,N) X(N,NRHS) B(N,NRHS)
        ! Note that if NRHS = N, and B is the identity, X is the inverse of A...
        ! Initialize inverse to the identity
        FSSMatI(:,:)=0.0
        do i=1,NumFSP
            do j=1,NumFSP
                if (j==i) then
                    FSSMatI(i,j)=1.0
                end if
            end do
        end do

        allocate(IPIV(NumFSP)) ! allocation storage for pivot array
        Call DGESV(NumFSP,NumFSP,FSSMat,NumFSP,IPIV,FSSMatI,NumFSP,INFO)
        if (INFO>0) then
            write(6,'(A)') 'Matrix inversion failed in WSolnSetup. Exiting...'
            stop
        end if

        ! Initialize source strengths and RHS to zero
        FSSource(:,:)=0.0
        FSRHS(:,:)=0.0
        FSRHSInd=1

    end if

    return
end subroutine WSolnSetup