*> \brief \b ZUNBDB
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZUNBDB + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
*                          X21, LDX21, X22, LDX22, THETA, PHI, TAUP1,
*                          TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          SIGNS, TRANS
*       INTEGER            INFO, LDX11, LDX12, LDX21, LDX22, LWORK, M, P,
*      $                   Q
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   PHI( * ), THETA( * )
*       COMPLEX*16         TAUP1( * ), TAUP2( * ), TAUQ1( * ), TAUQ2( * ),
*      $                   WORK( * ), X11( LDX11, * ), X12( LDX12, * ),
*      $                   X21( LDX21, * ), X22( LDX22, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZUNBDB simultaneously bidiagonalizes the blocks of an M-by-M
*> partitioned unitary matrix X:
*>
*>                                 [ B11 | B12 0  0 ]
*>     [ X11 | X12 ]   [ P1 |    ] [  0  |  0 -I  0 ] [ Q1 |    ]**H
*> X = [-----------] = [---------] [----------------] [---------]   .
*>     [ X21 | X22 ]   [    | P2 ] [ B21 | B22 0  0 ] [    | Q2 ]
*>                                 [  0  |  0  0  I ]
*>
*> X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is
*> not the case, then X must be transposed and/or permuted. This can be
*> done in constant time using the TRANS and SIGNS options. See ZUNCSD
*> for details.)
*>
*> The unitary matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by-
*> (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are
*> represented implicitly by Householder vectors.
*>
*> B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented
*> implicitly by angles THETA, PHI.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] TRANS
*> \verbatim
*>          TRANS is CHARACTER
*>          = 'T':      X, U1, U2, V1T, and V2T are stored in row-major
*>                      order;
*>          otherwise:  X, U1, U2, V1T, and V2T are stored in column-
*>                      major order.
*> \endverbatim
*>
*> \param[in] SIGNS
*> \verbatim
*>          SIGNS is CHARACTER
*>          = 'O':      The lower-left block is made nonpositive (the
*>                      "other" convention);
*>          otherwise:  The upper-right block is made nonpositive (the
*>                      "default" convention).
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows and columns in X.
*> \endverbatim
*>
*> \param[in] P
*> \verbatim
*>          P is INTEGER
*>          The number of rows in X11 and X12. 0 <= P <= M.
*> \endverbatim
*>
*> \param[in] Q
*> \verbatim
*>          Q is INTEGER
*>          The number of columns in X11 and X21. 0 <= Q <=
*>          MIN(P,M-P,M-Q).
*> \endverbatim
*>
*> \param[in,out] X11
*> \verbatim
*>          X11 is COMPLEX*16 array, dimension (LDX11,Q)
*>          On entry, the top-left block of the unitary matrix to be
*>          reduced. On exit, the form depends on TRANS:
*>          If TRANS = 'N', then
*>             the columns of tril(X11) specify reflectors for P1,
*>             the rows of triu(X11,1) specify reflectors for Q1;
*>          else TRANS = 'T', and
*>             the rows of triu(X11) specify reflectors for P1,
*>             the columns of tril(X11,-1) specify reflectors for Q1.
*> \endverbatim
*>
*> \param[in] LDX11
*> \verbatim
*>          LDX11 is INTEGER
*>          The leading dimension of X11. If TRANS = 'N', then LDX11 >=
*>          P; else LDX11 >= Q.
*> \endverbatim
*>
*> \param[in,out] X12
*> \verbatim
*>          X12 is COMPLEX*16 array, dimension (LDX12,M-Q)
*>          On entry, the top-right block of the unitary matrix to
*>          be reduced. On exit, the form depends on TRANS:
*>          If TRANS = 'N', then
*>             the rows of triu(X12) specify the first P reflectors for
*>             Q2;
*>          else TRANS = 'T', and
*>             the columns of tril(X12) specify the first P reflectors
*>             for Q2.
*> \endverbatim
*>
*> \param[in] LDX12
*> \verbatim
*>          LDX12 is INTEGER
*>          The leading dimension of X12. If TRANS = 'N', then LDX12 >=
*>          P; else LDX11 >= M-Q.
*> \endverbatim
*>
*> \param[in,out] X21
*> \verbatim
*>          X21 is COMPLEX*16 array, dimension (LDX21,Q)
*>          On entry, the bottom-left block of the unitary matrix to
*>          be reduced. On exit, the form depends on TRANS:
*>          If TRANS = 'N', then
*>             the columns of tril(X21) specify reflectors for P2;
*>          else TRANS = 'T', and
*>             the rows of triu(X21) specify reflectors for P2.
*> \endverbatim
*>
*> \param[in] LDX21
*> \verbatim
*>          LDX21 is INTEGER
*>          The leading dimension of X21. If TRANS = 'N', then LDX21 >=
*>          M-P; else LDX21 >= Q.
*> \endverbatim
*>
*> \param[in,out] X22
*> \verbatim
*>          X22 is COMPLEX*16 array, dimension (LDX22,M-Q)
*>          On entry, the bottom-right block of the unitary matrix to
*>          be reduced. On exit, the form depends on TRANS:
*>          If TRANS = 'N', then
*>             the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last
*>             M-P-Q reflectors for Q2,
*>          else TRANS = 'T', and
*>             the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last
*>             M-P-Q reflectors for P2.
*> \endverbatim
*>
*> \param[in] LDX22
*> \verbatim
*>          LDX22 is INTEGER
*>          The leading dimension of X22. If TRANS = 'N', then LDX22 >=
*>          M-P; else LDX22 >= M-Q.
*> \endverbatim
*>
*> \param[out] THETA
*> \verbatim
*>          THETA is DOUBLE PRECISION array, dimension (Q)
*>          The entries of the bidiagonal blocks B11, B12, B21, B22 can
*>          be computed from the angles THETA and PHI. See Further
*>          Details.
*> \endverbatim
*>
*> \param[out] PHI
*> \verbatim
*>          PHI is DOUBLE PRECISION array, dimension (Q-1)
*>          The entries of the bidiagonal blocks B11, B12, B21, B22 can
*>          be computed from the angles THETA and PHI. See Further
*>          Details.
*> \endverbatim
*>
*> \param[out] TAUP1
*> \verbatim
*>          TAUP1 is COMPLEX*16 array, dimension (P)
*>          The scalar factors of the elementary reflectors that define
*>          P1.
*> \endverbatim
*>
*> \param[out] TAUP2
*> \verbatim
*>          TAUP2 is COMPLEX*16 array, dimension (M-P)
*>          The scalar factors of the elementary reflectors that define
*>          P2.
*> \endverbatim
*>
*> \param[out] TAUQ1
*> \verbatim
*>          TAUQ1 is COMPLEX*16 array, dimension (Q)
*>          The scalar factors of the elementary reflectors that define
*>          Q1.
*> \endverbatim
*>
*> \param[out] TAUQ2
*> \verbatim
*>          TAUQ2 is COMPLEX*16 array, dimension (M-Q)
*>          The scalar factors of the elementary reflectors that define
*>          Q2.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX*16 array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK. LWORK >= M-Q.
*>
*>          If LWORK = -1, then a workspace query is assumed; the routine
*>          only calculates the optimal size of the WORK array, returns
*>          this value as the first entry of the WORK array, and no error
*>          message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit.
*>          < 0:  if INFO = -i, the i-th argument had an illegal value.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup complex16OTHERcomputational
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The bidiagonal blocks B11, B12, B21, and B22 are represented
*>  implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ...,
*>  PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are
*>  lower bidiagonal. Every entry in each bidiagonal band is a product
*>  of a sine or cosine of a THETA with a sine or cosine of a PHI. See
*>  [1] or ZUNCSD for details.
*>
*>  P1, P2, Q1, and Q2 are represented as products of elementary
*>  reflectors. See ZUNCSD for details on generating P1, P2, Q1, and Q2
*>  using ZUNGQR and ZUNGLQ.
*> \endverbatim
*
*> \par References:
*  ================
*>
*>  [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
*>      Algorithms, 50(1):33-65, 2009.
*>
*  =====================================================================
      SUBROUTINE ZUNBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12,
     $                   X21, LDX21, X22, LDX22, THETA, PHI, TAUP1,
     $                   TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO )
*
*  -- LAPACK computational routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      CHARACTER          SIGNS, TRANS
      INTEGER            INFO, LDX11, LDX12, LDX21, LDX22, LWORK, M, P,
     $                   Q
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   PHI( * ), THETA( * )
      COMPLEX*16         TAUP1( * ), TAUP2( * ), TAUQ1( * ), TAUQ2( * ),
     $                   WORK( * ), X11( LDX11, * ), X12( LDX12, * ),
     $                   X21( LDX21, * ), X22( LDX22, * )
*     ..
*
*  ====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   REALONE
      PARAMETER          ( REALONE = 1.0D0 )
      COMPLEX*16         ONE
      PARAMETER          ( ONE = (1.0D0,0.0D0) )
*     ..
*     .. Local Scalars ..
      LOGICAL            COLMAJOR, LQUERY
      INTEGER            I, LWORKMIN, LWORKOPT
      DOUBLE PRECISION   Z1, Z2, Z3, Z4
*     ..
*     .. External Subroutines ..
      EXTERNAL           ZAXPY, ZLARF, ZLARFGP, ZSCAL, XERBLA
      EXTERNAL           ZLACGV
*
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DZNRM2
      LOGICAL            LSAME
      EXTERNAL           DZNRM2, LSAME
*     ..
*     .. Intrinsic Functions
      INTRINSIC          ATAN2, COS, MAX, MIN, SIN
      INTRINSIC          DCMPLX, DCONJG
*     ..
*     .. Executable Statements ..
*
*     Test input arguments
*
      INFO = 0
      COLMAJOR = .NOT. LSAME( TRANS, 'T' )
      IF( .NOT. LSAME( SIGNS, 'O' ) ) THEN
         Z1 = REALONE
         Z2 = REALONE
         Z3 = REALONE
         Z4 = REALONE
      ELSE
         Z1 = REALONE
         Z2 = -REALONE
         Z3 = REALONE
         Z4 = -REALONE
      END IF
      LQUERY = LWORK .EQ. -1
*
      IF( M .LT. 0 ) THEN
         INFO = -3
      ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN
         INFO = -4
      ELSE IF( Q .LT. 0 .OR. Q .GT. P .OR. Q .GT. M-P .OR.
     $         Q .GT. M-Q ) THEN
         INFO = -5
      ELSE IF( COLMAJOR .AND. LDX11 .LT. MAX( 1, P ) ) THEN
         INFO = -7
      ELSE IF( .NOT.COLMAJOR .AND. LDX11 .LT. MAX( 1, Q ) ) THEN
         INFO = -7
      ELSE IF( COLMAJOR .AND. LDX12 .LT. MAX( 1, P ) ) THEN
         INFO = -9
      ELSE IF( .NOT.COLMAJOR .AND. LDX12 .LT. MAX( 1, M-Q ) ) THEN
         INFO = -9
      ELSE IF( COLMAJOR .AND. LDX21 .LT. MAX( 1, M-P ) ) THEN
         INFO = -11
      ELSE IF( .NOT.COLMAJOR .AND. LDX21 .LT. MAX( 1, Q ) ) THEN
         INFO = -11
      ELSE IF( COLMAJOR .AND. LDX22 .LT. MAX( 1, M-P ) ) THEN
         INFO = -13
      ELSE IF( .NOT.COLMAJOR .AND. LDX22 .LT. MAX( 1, M-Q ) ) THEN
         INFO = -13
      END IF
*
*     Compute workspace
*
      IF( INFO .EQ. 0 ) THEN
         LWORKOPT = M - Q
         LWORKMIN = M - Q
         WORK(1) = LWORKOPT
         IF( LWORK .LT. LWORKMIN .AND. .NOT. LQUERY ) THEN
            INFO = -21
         END IF
      END IF
      IF( INFO .NE. 0 ) THEN
         CALL XERBLA( 'xORBDB', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Handle column-major and row-major separately
*
      IF( COLMAJOR ) THEN
*
*        Reduce columns 1, ..., Q of X11, X12, X21, and X22
*
         DO I = 1, Q
*
            IF( I .EQ. 1 ) THEN
               CALL ZSCAL( P-I+1, DCMPLX( Z1, 0.0D0 ), X11(I,I), 1 )
            ELSE
               CALL ZSCAL( P-I+1, DCMPLX( Z1*COS(PHI(I-1)), 0.0D0 ),
     $                     X11(I,I), 1 )
               CALL ZAXPY( P-I+1, DCMPLX( -Z1*Z3*Z4*SIN(PHI(I-1)),
     $                     0.0D0 ), X12(I,I-1), 1, X11(I,I), 1 )
            END IF
            IF( I .EQ. 1 ) THEN
               CALL ZSCAL( M-P-I+1, DCMPLX( Z2, 0.0D0 ), X21(I,I), 1 )
            ELSE
               CALL ZSCAL( M-P-I+1, DCMPLX( Z2*COS(PHI(I-1)), 0.0D0 ),
     $                     X21(I,I), 1 )
               CALL ZAXPY( M-P-I+1, DCMPLX( -Z2*Z3*Z4*SIN(PHI(I-1)),
     $                     0.0D0 ), X22(I,I-1), 1, X21(I,I), 1 )
            END IF
*
            THETA(I) = ATAN2( DZNRM2( M-P-I+1, X21(I,I), 1 ),
     $                 DZNRM2( P-I+1, X11(I,I), 1 ) )
*
            IF( P .GT. I ) THEN
               CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
            ELSE IF ( P .EQ. I ) THEN
               CALL ZLARFGP( P-I+1, X11(I,I), X11(I,I), 1, TAUP1(I) )
            END IF
            X11(I,I) = ONE
            IF ( M-P .GT. I ) THEN
               CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1,
     $                       TAUP2(I) )
            ELSE IF ( M-P .EQ. I ) THEN
               CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I,I), 1,
     $                       TAUP2(I) )
            END IF
            X21(I,I) = ONE
*
            IF ( Q .GT. I ) THEN
               CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1,
     $                     DCONJG(TAUP1(I)), X11(I,I+1), LDX11, WORK )
               CALL ZLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1,
     $                     DCONJG(TAUP2(I)), X21(I,I+1), LDX21, WORK )
            END IF
            IF ( M-Q+1 .GT. I ) THEN
               CALL ZLARF( 'L', P-I+1, M-Q-I+1, X11(I,I), 1,
     $                     DCONJG(TAUP1(I)), X12(I,I), LDX12, WORK )
               CALL ZLARF( 'L', M-P-I+1, M-Q-I+1, X21(I,I), 1,
     $                     DCONJG(TAUP2(I)), X22(I,I), LDX22, WORK )
            END IF
*
            IF( I .LT. Q ) THEN
               CALL ZSCAL( Q-I, DCMPLX( -Z1*Z3*SIN(THETA(I)), 0.0D0 ),
     $                     X11(I,I+1), LDX11 )
               CALL ZAXPY( Q-I, DCMPLX( Z2*Z3*COS(THETA(I)), 0.0D0 ),
     $                     X21(I,I+1), LDX21, X11(I,I+1), LDX11 )
            END IF
            CALL ZSCAL( M-Q-I+1, DCMPLX( -Z1*Z4*SIN(THETA(I)), 0.0D0 ),
     $                  X12(I,I), LDX12 )
            CALL ZAXPY( M-Q-I+1, DCMPLX( Z2*Z4*COS(THETA(I)), 0.0D0 ),
     $                  X22(I,I), LDX22, X12(I,I), LDX12 )
*
            IF( I .LT. Q )
     $         PHI(I) = ATAN2( DZNRM2( Q-I, X11(I,I+1), LDX11 ),
     $                  DZNRM2( M-Q-I+1, X12(I,I), LDX12 ) )
*
            IF( I .LT. Q ) THEN
               CALL ZLACGV( Q-I, X11(I,I+1), LDX11 )
               IF ( I .EQ. Q-1 ) THEN
                  CALL ZLARFGP( Q-I, X11(I,I+1), X11(I,I+1), LDX11,
     $                          TAUQ1(I) )
               ELSE
                  CALL ZLARFGP( Q-I, X11(I,I+1), X11(I,I+2), LDX11,
     $                          TAUQ1(I) )
               END IF
               X11(I,I+1) = ONE
            END IF
            IF ( M-Q+1 .GT. I ) THEN
               CALL ZLACGV( M-Q-I+1, X12(I,I), LDX12 )
               IF ( M-Q .EQ. I ) THEN
                  CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12,
     $                          TAUQ2(I) )
               ELSE
                  CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
     $                          TAUQ2(I) )
               END IF
            END IF
            X12(I,I) = ONE
*
            IF( I .LT. Q ) THEN
               CALL ZLARF( 'R', P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I),
     $                     X11(I+1,I+1), LDX11, WORK )
               CALL ZLARF( 'R', M-P-I, Q-I, X11(I,I+1), LDX11, TAUQ1(I),
     $                     X21(I+1,I+1), LDX21, WORK )
            END IF
            IF ( P .GT. I ) THEN
               CALL ZLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
     $                     X12(I+1,I), LDX12, WORK )
            END IF
            IF ( M-P .GT. I ) THEN
               CALL ZLARF( 'R', M-P-I, M-Q-I+1, X12(I,I), LDX12,
     $                     TAUQ2(I), X22(I+1,I), LDX22, WORK )
            END IF
*
            IF( I .LT. Q )
     $         CALL ZLACGV( Q-I, X11(I,I+1), LDX11 )
            CALL ZLACGV( M-Q-I+1, X12(I,I), LDX12 )
*
         END DO
*
*        Reduce columns Q + 1, ..., P of X12, X22
*
         DO I = Q + 1, P
*
            CALL ZSCAL( M-Q-I+1, DCMPLX( -Z1*Z4, 0.0D0 ), X12(I,I),
     $                  LDX12 )
            CALL ZLACGV( M-Q-I+1, X12(I,I), LDX12 )
            IF ( I .GE. M-Q ) THEN
               CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I), LDX12,
     $                       TAUQ2(I) )
            ELSE
               CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I,I+1), LDX12,
     $                       TAUQ2(I) )
            END IF
            X12(I,I) = ONE
*
            IF ( P .GT. I ) THEN
               CALL ZLARF( 'R', P-I, M-Q-I+1, X12(I,I), LDX12, TAUQ2(I),
     $                     X12(I+1,I), LDX12, WORK )
            END IF
            IF( M-P-Q .GE. 1 )
     $         CALL ZLARF( 'R', M-P-Q, M-Q-I+1, X12(I,I), LDX12,
     $                     TAUQ2(I), X22(Q+1,I), LDX22, WORK )
*
            CALL ZLACGV( M-Q-I+1, X12(I,I), LDX12 )
*
         END DO
*
*        Reduce columns P + 1, ..., M - Q of X12, X22
*
         DO I = 1, M - P - Q
*
            CALL ZSCAL( M-P-Q-I+1, DCMPLX( Z2*Z4, 0.0D0 ),
     $                  X22(Q+I,P+I), LDX22 )
            CALL ZLACGV( M-P-Q-I+1, X22(Q+I,P+I), LDX22 )
            CALL ZLARFGP( M-P-Q-I+1, X22(Q+I,P+I), X22(Q+I,P+I+1),
     $                    LDX22, TAUQ2(P+I) )
            X22(Q+I,P+I) = ONE
            CALL ZLARF( 'R', M-P-Q-I, M-P-Q-I+1, X22(Q+I,P+I), LDX22,
     $                  TAUQ2(P+I), X22(Q+I+1,P+I), LDX22, WORK )
*
            CALL ZLACGV( M-P-Q-I+1, X22(Q+I,P+I), LDX22 )
*
         END DO
*
      ELSE
*
*        Reduce columns 1, ..., Q of X11, X12, X21, X22
*
         DO I = 1, Q
*
            IF( I .EQ. 1 ) THEN
               CALL ZSCAL( P-I+1, DCMPLX( Z1, 0.0D0 ), X11(I,I),
     $                     LDX11 )
            ELSE
               CALL ZSCAL( P-I+1, DCMPLX( Z1*COS(PHI(I-1)), 0.0D0 ),
     $                     X11(I,I), LDX11 )
               CALL ZAXPY( P-I+1, DCMPLX( -Z1*Z3*Z4*SIN(PHI(I-1)),
     $                     0.0D0 ), X12(I-1,I), LDX12, X11(I,I), LDX11 )
            END IF
            IF( I .EQ. 1 ) THEN
               CALL ZSCAL( M-P-I+1, DCMPLX( Z2, 0.0D0 ), X21(I,I),
     $                     LDX21 )
            ELSE
               CALL ZSCAL( M-P-I+1, DCMPLX( Z2*COS(PHI(I-1)), 0.0D0 ),
     $                     X21(I,I), LDX21 )
               CALL ZAXPY( M-P-I+1, DCMPLX( -Z2*Z3*Z4*SIN(PHI(I-1)),
     $                     0.0D0 ), X22(I-1,I), LDX22, X21(I,I), LDX21 )
            END IF
*
            THETA(I) = ATAN2( DZNRM2( M-P-I+1, X21(I,I), LDX21 ),
     $                 DZNRM2( P-I+1, X11(I,I), LDX11 ) )
*
            CALL ZLACGV( P-I+1, X11(I,I), LDX11 )
            CALL ZLACGV( M-P-I+1, X21(I,I), LDX21 )
*
            CALL ZLARFGP( P-I+1, X11(I,I), X11(I,I+1), LDX11, TAUP1(I) )
            X11(I,I) = ONE
            IF ( I .EQ. M-P ) THEN
               CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I,I), LDX21,
     $                       TAUP2(I) )
            ELSE
               CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I,I+1), LDX21,
     $                       TAUP2(I) )
            END IF
            X21(I,I) = ONE
*
            CALL ZLARF( 'R', Q-I, P-I+1, X11(I,I), LDX11, TAUP1(I),
     $                  X11(I+1,I), LDX11, WORK )
            CALL ZLARF( 'R', M-Q-I+1, P-I+1, X11(I,I), LDX11, TAUP1(I),
     $                  X12(I,I), LDX12, WORK )
            CALL ZLARF( 'R', Q-I, M-P-I+1, X21(I,I), LDX21, TAUP2(I),
     $                  X21(I+1,I), LDX21, WORK )
            CALL ZLARF( 'R', M-Q-I+1, M-P-I+1, X21(I,I), LDX21,
     $                  TAUP2(I), X22(I,I), LDX22, WORK )
*
            CALL ZLACGV( P-I+1, X11(I,I), LDX11 )
            CALL ZLACGV( M-P-I+1, X21(I,I), LDX21 )
*
            IF( I .LT. Q ) THEN
               CALL ZSCAL( Q-I, DCMPLX( -Z1*Z3*SIN(THETA(I)), 0.0D0 ),
     $                     X11(I+1,I), 1 )
               CALL ZAXPY( Q-I, DCMPLX( Z2*Z3*COS(THETA(I)), 0.0D0 ),
     $                     X21(I+1,I), 1, X11(I+1,I), 1 )
            END IF
            CALL ZSCAL( M-Q-I+1, DCMPLX( -Z1*Z4*SIN(THETA(I)), 0.0D0 ),
     $                  X12(I,I), 1 )
            CALL ZAXPY( M-Q-I+1, DCMPLX( Z2*Z4*COS(THETA(I)), 0.0D0 ),
     $                  X22(I,I), 1, X12(I,I), 1 )
*
            IF( I .LT. Q )
     $         PHI(I) = ATAN2( DZNRM2( Q-I, X11(I+1,I), 1 ),
     $                  DZNRM2( M-Q-I+1, X12(I,I), 1 ) )
*
            IF( I .LT. Q ) THEN
               CALL ZLARFGP( Q-I, X11(I+1,I), X11(I+2,I), 1, TAUQ1(I) )
               X11(I+1,I) = ONE
            END IF
            CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) )
            X12(I,I) = ONE
*
            IF( I .LT. Q ) THEN
               CALL ZLARF( 'L', Q-I, P-I, X11(I+1,I), 1,
     $                     DCONJG(TAUQ1(I)), X11(I+1,I+1), LDX11, WORK )
               CALL ZLARF( 'L', Q-I, M-P-I, X11(I+1,I), 1,
     $                     DCONJG(TAUQ1(I)), X21(I+1,I+1), LDX21, WORK )
            END IF
            CALL ZLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1,
     $                  DCONJG(TAUQ2(I)), X12(I,I+1), LDX12, WORK )
            IF ( M-P .GT. I ) THEN
               CALL ZLARF( 'L', M-Q-I+1, M-P-I, X12(I,I), 1,
     $                     DCONJG(TAUQ2(I)), X22(I,I+1), LDX22, WORK )
            END IF
*
         END DO
*
*        Reduce columns Q + 1, ..., P of X12, X22
*
         DO I = Q + 1, P
*
            CALL ZSCAL( M-Q-I+1, DCMPLX( -Z1*Z4, 0.0D0 ), X12(I,I), 1 )
            CALL ZLARFGP( M-Q-I+1, X12(I,I), X12(I+1,I), 1, TAUQ2(I) )
            X12(I,I) = ONE
*
            IF ( P .GT. I ) THEN
               CALL ZLARF( 'L', M-Q-I+1, P-I, X12(I,I), 1,
     $                     DCONJG(TAUQ2(I)), X12(I,I+1), LDX12, WORK )
            END IF
            IF( M-P-Q .GE. 1 )
     $         CALL ZLARF( 'L', M-Q-I+1, M-P-Q, X12(I,I), 1,
     $                     DCONJG(TAUQ2(I)), X22(I,Q+1), LDX22, WORK )
*
         END DO
*
*        Reduce columns P + 1, ..., M - Q of X12, X22
*
         DO I = 1, M - P - Q
*
            CALL ZSCAL( M-P-Q-I+1, DCMPLX( Z2*Z4, 0.0D0 ),
     $                  X22(P+I,Q+I), 1 )
            CALL ZLARFGP( M-P-Q-I+1, X22(P+I,Q+I), X22(P+I+1,Q+I), 1,
     $                    TAUQ2(P+I) )
            X22(P+I,Q+I) = ONE
*
            IF ( M-P-Q .NE. I ) THEN
               CALL ZLARF( 'L', M-P-Q-I+1, M-P-Q-I, X22(P+I,Q+I), 1,
     $                     DCONJG(TAUQ2(P+I)), X22(P+I,Q+I+1), LDX22,
     $                     WORK )
            END IF
*
         END DO
*
      END IF
*
      RETURN
*
*     End of ZUNBDB
*
      END


module extradof_parameters
  use amr_parameters

  ! free cubic vector Galileon parameter
  real(dp) :: param_b3=0.000001

  ! DGP model parameters  Chr 30/03/20
  real(dp) :: param_o=0.25D0    ! Omega_rc=1/(4*H0^2*rc^2) where rc is DGP scale
  real(dp) :: param_l=1.0d0      ! Omega_Lambda (only used if nDGP is true and nDGP2 is false)
  logical  :: nDGP=.true.        ! set to true to do nDGP, otherwise do sDGP
  logical  :: nDGP2=.false.       ! set to true to do nDGP with LCDM background, false for nDGP with a cosmological constant

  ! speed of light [meter/sec]
  real(dp) :: sol=299792458.0d0

  integer  :: ngs_fine_extradof_pre   = 30  ! pre-smoothing factor
  integer  :: ngs_fine_extradof_pst   = 3   ! post-smoothing factor
  integer  :: ngs_coarse_extradof_pre = 30  ! pre-smoothing factor
  integer  :: ngs_coarse_extradof_pst = 3   ! post-smoothing factor

end module extradof_parameters


!> JACOBI iteration subroutines.
!!
!! Subroutines for JACOBI iteration for the Crank--Nicholson and
!!  pressure steps. These subroutines use flux-conservative
!!   differencing, and the cell-averaged viscosities are copied from
!!    the master subroutine.
!!
!! @author Prashant Valluri, Lennon O Naraigh, Iain Bethune,
!! Toni Collis, David Scott, Peter Spelt.
!! @copyright (c) 2013-2015, Prashant Valluri, Lennon O Naraigh,
!! Toni Collis, Iain Bethune, David Scott, Peter Spelt.
!! This program is distributed under the BSD License See LICENSE.txt
!! for details.

module jacobi_iteration_allflux

  implicit none

contains

  subroutine do_jacobi_u(u3,u3_old,RHS,viscosity,dx,dy,dz,dt, &
       ex,ey,sx,sy,maxn,ex_max)

    implicit none

    ! Arguments
    integer,intent(in) :: sx,sy,ex,ey
    integer,intent(in) :: maxn,ex_max

    double precision,intent(inout) :: u3(sx-1:ex+1,sy-1:ey+1,0:maxn-2)
    double precision,intent(in) :: u3_old(sx-1:ex+1,sy-1:ey+1,0:maxn-2)
    double precision,intent(in) :: RHS(sx-1:ex+1,sy-1:ey+1,0:maxn-2)
    double precision,intent(in) :: viscosity(sx-2:ex+2,sy-2:ey+2,0:maxn)
    double precision,intent(in) :: dx,dy,dz,dt

    ! Local variables
    integer :: i,j,k,ex_loc

    double precision :: diag_val,ax,ay,az
    double precision :: mu_plushalf_x_val,mu_minushalf_x_val
    double precision :: mu_plushalf_y_val,mu_minushalf_y_val
    double precision :: mu_plushalf_z_val,mu_minushalf_z_val
    double precision :: u_minusz,u_plusz

    ax=dt/(dx*dx)
    ay=dt/(dy*dy)
    az=dt/(dz*dz)

    if(ex==ex_max)then
       ex_loc=ex-1
    else
       ex_loc=ex
    end if

    !$omp parallel default(shared), private(i,j,k,mu_plushalf_x_val,mu_minushalf_x_val, &
    !$omp& mu_plushalf_y_val,mu_minushalf_y_val,mu_plushalf_z_val,mu_minushalf_z_val,   &
    !$omp& diag_val,u_minusz,u_plusz)
    !$omp do
    do k=0,maxn-2
       do j=sy,ey
          do i=sx,ex_loc

             if(k.eq.0)then
                u_minusz=-2.d0*u3_old(i,j,0)+u3_old(i,j,1)/3.d0
             else
                u_minusz=u3_old(i,j,k-1)
             end if

             if(k.eq.(maxn-2))then
                u_plusz=-2.d0*u3_old(i,j,maxn-2)+u3_old(i,j,maxn-3)/3.d0
             else
                u_plusz=u3_old(i,j,k+1)
             end if

             mu_plushalf_x_val =viscosity(i+1,j+1,k+1)
             mu_minushalf_x_val=viscosity(i,  j+1,k+1)

             mu_plushalf_y_val =(viscosity(i,j+1,k+1)+viscosity(i+1,j+1,k+1)+viscosity(i,j+2,k+1)+viscosity(i+1,j+2,k+1))/4.d0
             mu_minushalf_y_val=(viscosity(i,j+1,k+1)+viscosity(i+1,j+1,k+1)+viscosity(i,j  ,k+1)+viscosity(i+1,j  ,k+1))/4.d0

             mu_plushalf_z_val =(viscosity(i,j+1,k+1)+viscosity(i+1,j+1,k+1)+viscosity(i,j+1,k+2)+viscosity(i+1,j+1,k+2))/4.d0
             mu_minushalf_z_val=(viscosity(i,j+1,k+1)+viscosity(i+1,j+1,k+1)+viscosity(i,j+1,k  )+viscosity(i+1,j+1,k  ))/4.d0

             diag_val=1.d0+(ax/2.d0)*(mu_plushalf_x_val+mu_minushalf_x_val)+&
                  (ay/2.d0)*(mu_plushalf_y_val+mu_minushalf_y_val)+&
                  (az/2.d0)*(mu_plushalf_z_val+mu_minushalf_z_val)

             u3(i,j,k) = (1.d0/diag_val) * ( (ax/2.d0)*(mu_plushalf_x_val*u3_old(i+1,j,k)+mu_minushalf_x_val*u3_old(i-1,j,k)) + &
                  (ay/2.d0)*(mu_plushalf_y_val*u3_old(i,j+1,k)+mu_minushalf_y_val*u3_old(i,j-1,k)) + &
                  (az/2.d0)*(mu_plushalf_z_val*u_plusz    +mu_minushalf_z_val*u_minusz   ) + RHS(i,j,k))

          end do
       end do
    end do
    !$omp end do
    !$omp end parallel

    return
  end subroutine do_jacobi_u

  subroutine do_jacobi_v(v3,v3_old,RHS,viscosity,dx,dy,dz,dt, &
       ex,ey,sx,sy,maxn,ex_max)

    implicit none

    ! Arguments
    integer,intent(in) :: sx,sy,ex,ey
    integer,intent(in) :: maxn,ex_max

    double precision,intent(inout) :: v3(sx-1:ex+1,sy-1:ey+1,0:maxn-2)
    double precision,intent(in) :: v3_old(sx-1:ex+1,sy-1:ey+1,0:maxn-2)
    double precision,intent(in) :: RHS(sx-1:ex+1,sy-1:ey+1,0:maxn-2)
    double precision,intent(in) :: viscosity(sx-2:ex+2,sy-2:ey+2,0:maxn)
    double precision,intent(in) :: dx,dy,dz,dt

    ! Local variables
    integer :: i,j,k

    double precision :: diag_val,ax,ay,az
    double precision :: mu_plushalf_x_val,mu_minushalf_x_val
    double precision :: mu_plushalf_y_val,mu_minushalf_y_val
    double precision :: mu_plushalf_z_val,mu_minushalf_z_val
    double precision :: v_minusz,v_plusz,v_plusx,v_minusx

    ax=dt/(dx*dx)
    ay=dt/(dy*dy)
    az=dt/(dz*dz)

    !$omp parallel default(shared), private(i,j,k,mu_plushalf_x_val,mu_minushalf_x_val, &
    !$omp& mu_plushalf_y_val,mu_minushalf_y_val,mu_plushalf_z_val,mu_minushalf_z_val,   &
    !$omp& diag_val,v_minusz,v_plusz,v_minusx,v_plusx)
    !$omp do
    do k=0,maxn-2
       do j=sy,ey
          do i=sx,ex

             if(k.eq.0)then
                v_minusz=-2.d0*v3_old(i,j,0)+v3_old(i,j,1)/3.d0
             else
                v_minusz=v3_old(i,j,k-1)
             end if

             if(k.eq.(maxn-2))then
                v_plusz=-2.d0*v3_old(i,j,maxn-2)+v3_old(i,j,maxn-3)/3.d0
             else
                v_plusz=v3_old(i,j,k+1)
             end if

             v_plusx=v3_old(i+1,j,k)
             v_minusx=v3_old(i-1,j,k)

             mu_plushalf_x_val= (viscosity(i,j+1,k+1)+viscosity(i,j,k+1)+viscosity(i+1,j+1,k+1)+viscosity(i+1,j,k+1))/4.d0
             mu_minushalf_x_val=(viscosity(i,j+1,k+1)+viscosity(i,j,k+1)+viscosity(i-1,j+1,k+1)+viscosity(i-1,j,k+1))/4.d0

             mu_plushalf_y_val= viscosity(i,j+1,k+1)
             mu_minushalf_y_val=viscosity(i,j,  k+1)

             mu_plushalf_z_val= (viscosity(i,j+1,k+1)+viscosity(i,j,k+1)+viscosity(i,j+1,k+2)+viscosity(i,j,k+2))/4.d0
             mu_minushalf_z_val=(viscosity(i,j+1,k+1)+viscosity(i,j,k+1)+viscosity(i,j+1,k  )+viscosity(i,j,k  ))/4.d0

             diag_val=1.d0+(ax/2.d0)*(mu_plushalf_x_val+mu_minushalf_x_val)+&
                  (ay/2.d0)*(mu_plushalf_y_val+mu_minushalf_y_val)+&
                  (az/2.d0)*(mu_plushalf_z_val+mu_minushalf_z_val)

             v3(i,j,k) = (1.d0/diag_val) * ( (ax/2.d0)*(mu_plushalf_x_val*v_plusx        +mu_minushalf_x_val*v_minusx       ) + &
                  (ay/2.d0)*(mu_plushalf_y_val*v3_old(i,j+1,k)+mu_minushalf_y_val*v3_old(i,j-1,k)) + &
                  (az/2.d0)*(mu_plushalf_z_val*v_plusz    +mu_minushalf_z_val*v_minusz           ) + &
                  RHS(i,j,k))

          end do
       end do
    end do
    !$omp end do
    !$omp end parallel

    if(sx==1)then
       do k=0,maxn-2
          do j=sy,ey
             ! v3(0,j,k)=-(dx/dy)*(u3(0,j,k)-u3(0,j-1,k)) +(dt/dy)*(pres(1,j+1,k+1)-pres(1,j,k+1))
             v3(0,j,k)=v3(1,j,k)
          end do
       end do
    end if

    if(ex==ex_max)then
       v3(ex_max+1,sy:ey,:)=v3(ex_max,sy:ey,:)
    end if

    return
  end subroutine do_jacobi_v

  subroutine do_jacobi_w(w3,w3_old,RHS,viscosity,dx,dy,dz,dt, &
      ex,ey,sx,sy,maxn,ex_max)

    implicit none

    ! Arguments
    integer,intent(in) :: sx,sy,ex,ey
    integer,intent(in) :: maxn,ex_max

    double precision,intent(inout) :: w3(sx-1:ex+1,sy-1:ey+1,0:maxn-1)
    double precision,intent(in) :: w3_old(sx-1:ex+1,sy-1:ey+1,0:maxn-1)
    double precision,intent(in) :: RHS(sx-1:ex+1,sy-1:ey+1,0:maxn-1)
    double precision,intent(in) :: viscosity(sx-2:ex+2,sy-2:ey+2,0:maxn)
    double precision,intent(in) :: dx,dy,dz,dt

    ! Local variables
    integer :: i,j,k

    double precision :: diag_val,ax,ay,az
    double precision :: mu_plushalf_x_val,mu_minushalf_x_val
    double precision :: mu_plushalf_y_val,mu_minushalf_y_val
    double precision :: mu_plushalf_z_val,mu_minushalf_z_val
    double precision :: w_plusx,w_minusx

    ax=dt/(dx*dx)
    ay=dt/(dy*dy)
    az=dt/(dz*dz)

    !$omp parallel default(shared), private(i,j,k,mu_plushalf_x_val,mu_minushalf_x_val, &
    !$omp& mu_plushalf_y_val,mu_minushalf_y_val,mu_plushalf_z_val,mu_minushalf_z_val,   &
    !$omp& diag_val,w_minusx,w_plusx)
    !$omp do
    do k=1,maxn-2
       do j=sy,ey
          do i=sx,ex

             mu_plushalf_x_val= (viscosity(i,j+1,k)+viscosity(i,j+1,k+1)+viscosity(i+1,j+1,k)+viscosity(i+1,j+1,k+1))/4.d0
             mu_minushalf_x_val=(viscosity(i,j+1,k)+viscosity(i,j+1,k+1)+viscosity(i-1,j+1,k)+viscosity(i-1,j+1,k+1))/4.d0

             mu_plushalf_y_val= (viscosity(i,j+1,k)+viscosity(i,j+1,k+1)+viscosity(i,j+2,k)+viscosity(i,j+2,k+1))/4.d0
             mu_minushalf_y_val=(viscosity(i,j+1,k)+viscosity(i,j+1,k+1)+viscosity(i,j  ,k)+viscosity(i,j  ,k+1))/4.d0

             mu_plushalf_z_val=  viscosity(i,j+1,k+1)
             mu_minushalf_z_val= viscosity(i,j+1,k  )

             w_plusx=w3_old(i+1,j,k)
             w_minusx=w3_old(i-1,j,k)

             diag_val=1.d0+(ax/2.d0)*(mu_plushalf_x_val+mu_minushalf_x_val)+&
                  (ay/2.d0)*(mu_plushalf_y_val+mu_minushalf_y_val)+&
                  (az/2.d0)*(mu_plushalf_z_val+mu_minushalf_z_val)

             w3(i,j,k) = (1.d0/diag_val) * ( (ax/2.d0)*(mu_plushalf_x_val*w_plusx        +mu_minushalf_x_val*w_minusx       ) + &
                  (ay/2.d0)*(mu_plushalf_y_val*w3_old(i,j+1,k)+mu_minushalf_y_val*w3_old(i,j-1,k)) + &
                  (az/2.d0)*(mu_plushalf_z_val*w3_old(i,j,k+1)+mu_minushalf_z_val*w3_old(i,j,k-1)) + &
                  RHS(i,j,k))

          end do
       end do
    end do
    !$omp end do

    !$omp workshare
    w3(sx:ex,sy:ey,0)=0.d0
    w3(sx:ex,sy:ey,maxn-1)=0.d0
    !$omp end workshare nowait
    !$omp end parallel

    if(sx==1)then
       do k=1,maxn-2
          do j=sy,ey
             ! w3(0,j,k)=(dx/dz)*( (u_inlet(k)-u_inlet(k-1) )  -(u3(0,j,k)-u3(0,j,k-1))) &
             !  +(dt/dz)*(pres(1,j+1,k+1)-pres(1,j+1,k))
             w3(0,j,k)=w3(1,j,k)
          end do
       end do

       w3(0,sy:ey,0)=0.d0
       w3(0,sy:ey,maxn-1)=0.d0

    end if

    if(ex==ex_max)then
       w3(ex_max+1,sy:ey,:)=w3(ex_max,sy:ey,:)
    end if

    return
  end subroutine do_jacobi_w

  subroutine get_difference(ua,ub,ex,ey,ez,sx,sy,sz,diff)
    implicit none

    ! Arguments
    integer, intent(in) :: ex,ey,ez,sx,sy,sz

    double precision, dimension(sx-1:ex+1,sy-1:ey+1,sz:ez), intent(in) :: ua, ub
    double precision, intent(out) :: diff

    ! Local variables
    integer :: i,j,k

    diff = 0.0d0
    !$omp parallel default(shared), private(i,j,k), reduction(+:diff)
    !$omp do
    do k=sz,ez
       do j = sy,ey
          do i = sx,ex
             diff = diff + (ua(i,j,k)-ub(i,j,k))**2
          end do
       end do
    end do
    !$omp end do
    !$omp end parallel

    return
  end subroutine get_difference

end module jacobi_iteration_allflux


module advect_um_lib

! function & subroutine library for the 5th ULTIMATE-MACHO scheme

	use grid
	implicit none

	logical, parameter :: fct = .true. ! apply FCT for monotone

	! Used to judge if courant unuber needs to be updated.
	! Courant number is same for same icycle.
	integer :: nstep_adv = 0
	integer :: icycle_adv = 0 ! TAK 2014/05: icycle counter
!@ TAK 2014/05: This does not work with ncycle_max > 4
!@	logical, dimension(4) :: updated_cn = .false. ! maximum icycle is 4. See kurant.f90

	! Courant number
	real, dimension(dimx1_u:dimx2_u, dimy1_u:dimy2_u, nzm) :: cu
	real, dimension(dimx1_v:dimx2_v, dimy1_v:dimy2_v, nzm) :: cv
	real, dimension(dimx1_w:dimx2_w, dimy1_w:dimy2_w, nz ) :: cw

	! Inverse of adz, adzw, rho and rhow*adz, common for same icycle
	real, dimension(nzm) :: iadz, iadzw, irho, irhow

	! f for advective form update, face values
	real, dimension(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm) :: fadv
	real, dimension(0:nxp2,          dimy1_s:dimy2_s, nzm) :: fx
	real, dimension(dimx1_s:dimx2_s, 0:nyp2,          nzm) :: fy
	real, dimension(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nz ) :: fz

contains

!--------------------------------------------------------------------------------------------------

	real function face_2nd( f_im1, f_i, cn )

		! Returns face value at left side of i-th control volume, f_i

		implicit none

		! input
		real, intent(in) :: f_im1, f_i, cn

		! Face value
		face_2nd = 0.5 * ( f_i + f_im1 - cn * ( f_i - f_im1 ) )

	end function face_2nd

	!--------------------------------------------------------------------------------------------------

	real function face_2nd_z( f_im1, f_i, cn, i )

		! Returns face value for non-uniform grid. Only used for vertial grid

		implicit none

		! input
		real, intent(in) :: f_im1, f_i, cn
		integer, intent(in) :: i

		! Face value
		face_2nd_z = 0.5 * ( f_i + f_im1 - cn * adz(i) * iadzw(i) * ( f_i - f_im1 ) )

	end function face_2nd_z

	!--------------------------------------------------------------------------------------------------

	real function face_3rd( f_im2, f_im1, f_i, f_ip1, cn )

		implicit none

		! input
		real, intent(in) :: f_im2, f_im1, f_i, f_ip1, cn

		! local
		real :: difference2, difference3

		! 2nd & 3rd difference
		difference2 = f_ip1 - f_i - f_im1 + f_im2
		difference3 = f_ip1 - 3.*f_i + 3.*f_im1 - f_im2

		! Face value
		face_3rd = 0.5 * ( f_i + f_im1 - cn * ( f_i - f_im1 ) &
			+ 1./6. * (cn*cn-1.) * ( difference2 - sign(1.,cn) * difference3 ) )

	end function face_3rd

	!--------------------------------------------------------------------------------------------------

	real function face_3rd_z( f_im2, f_im1, f_i, f_ip1, cn, i )

		implicit none

		! input
		real, intent(in) :: f_im2, f_im1, f_i, f_ip1, cn
		integer, intent(in) :: i

		! local
		real :: positive_3rd, negative_3rd

		positive_3rd = 1./6. * ( cn * cn * adz(i) * adz(i) * iadzw(i) * iadzw(i-1) - 1. ) &
			* ( adzw(i-1) * iadz(i-1) * ( f_i - f_im1 ) - adzw(i) * iadz(i-1) * ( f_im1 - f_im2 ) )
		negative_3rd = 1./6. * ( cn * cn * adz(i) * adz(i) * iadzw(i+1) * adzw(i) - 1. ) &
			* ( adzw(i) * iadz(i) * ( f_ip1 - f_i ) - adzw(i+1) * iadz(i) * ( f_i - f_im1 ) )

		! Face value
		face_3rd_z = 0.5 * ( f_i + f_im1 - cn * adz(i) * iadzw(i) * ( f_i - f_im1 ) &
			+ positive_3rd + negative_3rd + sign(1.,cn) * ( positive_3rd - negative_3rd ) )

	end function face_3rd_z

	!--------------------------------------------------------------------------------------------------

	real function face_5th( f_im3, f_im2, f_im1, f_i, f_ip1, f_ip2, cn )

		implicit none

		! input
		real, intent(in) :: f_im3, f_im2, f_im1, f_i, f_ip1, f_ip2, cn

		! local
		real :: difference2, difference3, difference4, difference5

		! 2-5th difference
		difference2 = f_ip1 - f_i - f_im1 + f_im2
		difference3 = f_ip1 - 3.*f_i + 3.*f_im1 - f_im2
		difference4 = f_ip2 - 3.*f_ip1 + 2.*f_i + 2.*f_im1 - 3.*f_im2 + f_im3
		difference5 = f_ip2 - 5.*f_ip1 + 10.*f_i - 10.*f_im1 + 5.*f_im2 - f_im3

		! Face value
		face_5th = 0.5 * ( f_i + f_im1 - cn * ( f_i - f_im1 ) &
			+ 1./6. * (cn*cn-1.) * ( difference2 - 0.5 * cn * difference3 ) &
			+ 1./120. * (cn*cn-1.) * (cn*cn-4.) * ( difference4 - sign(1.,cn) * difference5 ) )

	end function face_5th

	!--------------------------------------------------------------------------------------------------

	real function face_5th_z( f_im3, f_im2, f_im1, f_i, f_ip1, f_ip2, cn, i )

		implicit none

		! input
		real, intent(in) :: f_im3, f_im2, f_im1, f_i, f_ip1, f_ip2, cn
		integer, intent(in) :: i

		! local
		real :: positive_5th, negative_5th

		positive_5th = 1./120. * ( cn * cn * adz(i) * adz(i) * iadzw(i) * iadzw(i-1) - 1. ) &
			* ( cn * cn * adz(i) * adz(i) * iadzw(i+1) * iadzw(i-2) - 4. ) &
			* ( adzw(i-1) * adzw(i-2) * iadz(i) * iadz(i-1) * ( f_ip1 - f_i ) &
			  - adzw(i+1) * adzw(i-2) * (adzw(i-1) * adz(i-1) + adzw(i-1) * adz(i) + adzw(i) * adz(i)) &
			    * iadzw(i) * iadz(i) * iadz(i-1) * iadz(i-1) * ( f_i - f_im1 ) &
			  + adzw(i+1) * adzw(i-2) * (adzw(i-1) * adz(i-2) + adzw(i) * adz(i-2) + adzw(i) *adz(i-1))&
			    * iadzw(i-1) * iadz(i-1) * iadz(i-1) * iadz(i-2) * ( f_im1 - f_im2 ) &
			  - adzw(i+1) * adzw(i) * iadz(i-1) * iadz(i-2) * ( f_im2 - f_im3 ) )

		negative_5th = 1./120. * ( cn * cn * adz(i) * adz(i) * iadzw(i+1) * iadzw(i) - 1. ) &
			* ( cn  * cn * adz(i) * adz(i) * iadzw(i+2) * iadzw(i-1) - 4. ) &
			* ( adzw(i) * adzw(i-1) * iadz(i+1) * iadz(i) * ( f_ip2 - f_ip1 ) &
			  - adzw(i+2) * adzw(i-1) * (adzw(i) * adz(i) + adzw(i) * adz(i+1) + adzw(i+1) * adz(i+1)) &
			    * iadzw(i+1) * iadz(i+1) * iadz(i) * iadz(i) * ( f_ip1 - f_i ) &
			  + adzw(i+2) * adzw(i-1) * (adzw(i) * adz(i-1) + adzw(i+1) * adz(i-1) + adzw(i+1) *adz(i))&
			    * iadzw(i) * iadz(i) * iadz(i) * iadz(i-1) * ( f_i - f_im1 ) &
			  - adzw(i+2) * adzw(i+1) * iadz(i) * iadz(i-1) * ( f_im1 - f_im2 ) )

		! Face value
		face_5th_z = 0.5 * ( f_i + f_im1 - cn * adz(i) * iadzw(i) * ( f_i - f_im1 ) &
			+ 1./3. * ( cn * cn * adz(i) * adz(i) * iadzw(i+1) * iadzw(i-1) - 1. ) &
			  * ( adzw(i-1) / ( adz(i) + adz(i-1) ) * ( f_ip1 - f_i ) &
			    - adzw(i+1) / ( adz(i) + adz(i-1) )  * ( f_im1 - f_im2 ) ) &
			- 1./12. * ( cn * cn * adz(i) * adz(i) * iadzw(i+1) * adzw(i-1) - 1. ) * cn*adz(i)*iadzw(i)&
			  * ( adzw(i-1) * iadz(i) * ( f_ip1 - f_i ) &
			    - adzw(i+1)*adzw(i-1)*(adz(i-1)+adz(i))*iadzw(i)*iadz(i)*iadz(i-1) * ( f_i - f_im1 ) &
			    + adzw(i+1) * iadz(i-1) * ( f_im1 - f_im2 ) ) &
			+ positive_5th + negative_5th + sign(1.,cn) * ( positive_5th - negative_5th ) )

	end function face_5th_z

	!--------------------------------------------------------------------------------------------------

	real function advective_cn( cn_left, cn_right )

		! Returns advective courant number
		implicit none
		real, intent(in) :: cn_left, cn_right

		! original method to estimate advective velocity for advective update
		if ( (cn_right > 0.).and.(cn_left >= 0.) ) then
			advective_cn = cn_left
		else if ( (cn_right <= 0.).and.(cn_left < 0.) ) then
			advective_cn = cn_right
		else
			advective_cn = 0.
		endif

	end function advective_cn

	!--------------------------------------------------------------------------------------------------

	subroutine face_x_5th( x1, x2, y1, y2, z1, z2 )

		use grid
		implicit none

		! input
		integer, intent(in) :: x1, x2, y1, y2, z1, z2

		! local
		integer :: i, j, k

		do k = z1, z2
			do j = y1, y2
				do i = x1, x2
					fx(i,j,k) = face_5th( fadv(i-3,j,k), fadv(i-2,j,k), fadv(i-1,j,k), fadv(i,j,k), &
					                      fadv(i+1,j,k), fadv(i+2,j,k), cu(i,j,k) )
				enddo
			enddo
		enddo

	end subroutine face_x_5th

	!--------------------------------------------------------------------------------------------------

	subroutine face_y_5th( x1, x2, y1, y2, z1, z2 )

		use grid
		implicit none

		! input
		integer, intent(in) :: x1, x2, y1, y2, z1, z2

		! local
		integer :: i, j, k

		do k = z1, z2
			do j = y1, y2
				do i = x1, x2
					fy(i,j,k) = face_5th( fadv(i,j-3,k), fadv(i,j-2,k), fadv(i,j-1,k), fadv(i,j,k), &
					                      fadv(i,j+1,k), fadv(i,j+2,k), cv(i,j,k) )
				enddo
			enddo
		enddo

	end subroutine face_y_5th

	!--------------------------------------------------------------------------------------------------

	subroutine face_z_5th( x1, x2, y1, y2, z1, z2 )

		use grid
		implicit none

		! input
		integer, intent(in) :: x1, x2, y1, y2, z1, z2

		! local
		integer :: i, j, k

                if(z1.lt.4) then
		do j = y1, y2
			do i = x1, x2
				fz(i,j,2) = face_2nd_z( fadv(i,j,1), fadv(i,j,2), cw(i,j,2), 2 )
				fz(i,j,3) = face_3rd_z( fadv(i,j,1), fadv(i,j,2), fadv(i,j,3), fadv(i,j,4), cw(i,j,3),3)
			enddo
		enddo
                end if

		do k = MAX(z1,4), MIN(z2,nzm-2)
			do j = y1, y2
				do i = x1, x2
					fz(i,j,k) = face_5th_z( fadv(i,j,k-3), fadv(i,j,k-2), fadv(i,j,k-1), fadv(i,j,k), &
					                        fadv(i,j,k+1), fadv(i,j,k+2), cw(i,j,k), k )
				enddo
			enddo
		enddo

                if(z2.gt.nzm-2) then
                  do j = y1, y2
                    do i = x1, x2
                      fz(i,j,nzm-1) = face_3rd_z( fadv(i,j,nzm-3), fadv(i,j,nzm-2), fadv(i,j,nzm-1), &
                           fadv(i,j,nzm), cw(i,j,nzm-1), nzm-1 )
                      fz(i,j,nzm) = face_2nd_z( fadv(i,j,nzm-1), fadv(i,j,nzm), cw(i,j,nzm), nzm )
                    enddo
                  enddo
                end if

	end subroutine face_z_5th

	!--------------------------------------------------------------------------------------------------

	subroutine adv_form_update_x( x1, x2, y1, y2, z1, z2 )

		use grid
		implicit none

		! input
		integer, intent(in) :: x1, x2, y1, y2, z1, z2

		! local
		integer :: i, j, k

		do k = z1, z2
			do j = y1, y2
				do i = x1, x2
					fadv(i,j,k) = fadv(i,j,k) &
						+ advective_cn( cu(i,j,k), cu(i+1,j,k) )  * ( fx(i,j,k) - fx(i+1,j,k) )
				enddo
			enddo
		enddo

	end subroutine adv_form_update_x

	!--------------------------------------------------------------------------------------------------

	subroutine adv_form_update_y( x1, x2, y1, y2, z1, z2 )

		use grid
		implicit none

		!	input
		integer, intent(in) :: x1, x2, y1, y2, z1, z2

		!	local
		integer :: i, j, k

		do k = z1, z2
			do j = y1, y2
				do i = x1, x2
					fadv(i,j,k) = fadv(i,j,k) &
						+ advective_cn( cv(i,j,k), cv(i,j+1,k) ) * ( fy(i,j,k) - fy(i,j+1,k) )
				enddo
			enddo
		enddo

	end subroutine adv_form_update_y

	!--------------------------------------------------------------------------------------------------

	subroutine adv_form_update_z( x1, x2, y1, y2, z1, z2 )

		use grid
		implicit none

		! input
		integer, intent(in) :: x1, x2, y1, y2, z1, z2

		! local
		integer :: i, j, k

		do k = MAX(z1,2), MIN(z2,nzm-1)
			do j = y1, y2
				do i = x1, x2
					fadv(i,j,k) = fadv(i,j,k) &
						+ advective_cn( cw(i,j,k), cw(i,j,k+1) ) * ( fz(i,j,k) - fz(i,j,k+1) )
				enddo
			enddo
		enddo

	end subroutine adv_form_update_z

	!--------------------------------------------------------------------------------------------------

	subroutine fct3D( f, u, v, w, flux, z1, z2 )

		! Flux corrected transport to enforce monotonicity
		! input: u, v, w: mass weighted courant number

		use grid
		implicit none

		! input & output
		real, dimension(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm), intent(inout) :: f

		! input
                integer, intent(in) :: z1, z2
		real, dimension(dimx1_u:dimx2_u, dimy1_u:dimy2_u, nzm), intent(in) :: u
		real, dimension(dimx1_v:dimx2_v, dimy1_v:dimy2_v, nzm), intent(in) :: v
		real, dimension(dimx1_w:dimx2_w, dimy1_w:dimy2_w, nz ), intent(in) :: w

		! output
		real, dimension(nz), intent(out) :: flux

		! local
		real, dimension(-1:nxp3, -1:nyp2, nzm) :: flx_x
		real, dimension(-1:nxp2, -1:nyp3, nzm) :: flx_y
		real, dimension(-1:nxp2, -1:nyp2, nz ) :: flx_z
		real, dimension(0:nxp1, 0:nyp1, nzm) :: mn, mx
		integer :: i, j, k, km1, kp1
		real, parameter :: eps = 1.e-10

		! Set bottom and top vertical flux zero, also horizontal sum of vertical flux for output
		flx_z(:,:,1:z1)  = 0.
		flx_z(:,:,z2:nz) = 0.
		flux(:) = 0.

		! min and max bound with f
		do k = MAX(1,z1), MIN(z2,nzm)
			km1 = max(1,k-1)
			kp1 = min(k+1,nzm)
			do j = 0, nyp1
				do i = 0, nxp1
					mn(i,j,k) = min( f(i,j,k), f(i-1,j,k), f(i+1,j,k), f(i,j-1,k), f(i,j+1,k), &
					                 f(i,j,km1), f(i,j,kp1) )

					mx(i,j,k) = max( f(i,j,k), f(i-1,j,k), f(i+1,j,k), f(i,j-1,k), f(i,j+1,k), &
					                 f(i,j,km1), f(i,j,kp1) )
				enddo
			enddo
		enddo

		! 1st order upwind flux
		do k = MAX(1,z1), MIN(z2,nzm)
			do j = -1, nyp2
				do i = -1, nxp3
					flx_x(i,j,k) = f(i-1,j,k) * max( 0., u(i,j,k) ) + f(i,j,k) * min( 0., u(i,j,k) )
				enddo
			enddo

			do j = -1, nyp3
				do i = -1, nxp2
					flx_y(i,j,k) = f(i,j-1,k) * max( 0., v(i,j,k) ) + f(i,j,k) * min( 0., v(i,j,k) )
				enddo
			enddo
		enddo
		do k = MAX(2,z1), MIN(nzm,z2)
			do j = -1, nyp2
				do i = -1, nxp2
					flx_z(i,j,k) = f(i,j,k-1) * max( 0., w(i,j,k) ) + f(i,j,k) * min( 0., w(i,j,k) )
				enddo
			enddo
		enddo

		! 1st order upwind update
		do k = MAX(1,z1), MIN(z2,nzm)
			do j = -1, nyp2
				do i = -1, nxp2
					f(i,j,k) = f(i,j,k) &
						+ ( flx_x(i,j,k) - flx_x(i+1,j,k) + flx_y(i,j,k) - flx_y(i,j+1,k) &
						+ ( flx_z(i,j,k) - flx_z(i,j,k+1) ) * iadz(k) ) * irho(k)
				enddo
			enddo
			do j = 1, ny
				do i = 1, nx
					flux(k) = flux(k) + flx_z(i,j,k)
				enddo
			enddo
		enddo

		! Antidiffusive flux
		do k = MAX(1,z1), MIN(z2,nzm)
			do j = 0, nyp1
				do i = 0, nxp2
					flx_x(i,j,k) = u(i,j,k) * fx(i,j,k) - flx_x(i,j,k)
				enddo
			enddo

			do j = 0, nyp2
				do i = 0, nxp1
					flx_y(i,j,k) = v(i,j,k) * fy(i,j,k) - flx_y(i,j,k)
				enddo
			enddo
		enddo
		do k = MAX(2,z1), MIN(nzm,z2)
			do j = 0, nyp1
				do i = 0, nxp1
					flx_z(i,j,k) = w(i,j,k) * fz(i,j,k) - flx_z(i,j,k)
				enddo
			enddo
		enddo

		! min and max bounds with upwind-updated f
		! convert mn and mx to outflow and inflow fct scale factor
		do k = MAX(1,z1), MIN(z2,nzm)
			km1 = max(1,k-1)
			kp1 = min(k+1,nzm)
			do j = 0, nyp1
				do i = 0, nxp1

					mn(i,j,k) = min( f(i,j,k), f(i-1,j,k), f(i+1,j,k), f(i,j-1,k), f(i,j+1,k), &
					                 f(i,j,km1), f(i,j,kp1), mn(i,j,k) )

					mx(i,j,k) = max( f(i,j,k), f(i-1,j,k), f(i+1,j,k), f(i,j-1,k), f(i,j+1,k), &
					                 f(i,j,km1), f(i,j,kp1), mx(i,j,k) )

					! total higher-order outflow flux
					! outflow fct factor
					mn(i,j,k) = ( f(i,j,k) - mn(i,j,k) ) &
					      / ( ( max(0.,flx_x(i+1,j,k)) - min(0.,flx_x(i,j,k))  &
					          + max(0.,flx_y(i,j+1,k)) - min(0.,flx_y(i,j,k))  &
					        + ( max(0.,flx_z(i,j,k+1)) - min(0.,flx_z(i,j,k)))*iadz(k) )*irho(k) + eps )

					! total higher-order inflow flux
					! inflow fct factor
					mx(i,j,k) = ( mx(i,j,k) - f(i,j,k) ) &
					      / ( ( max(0.,flx_x(i,j,k)) - min(0.,flx_x(i+1,j,k)) &
					          + max(0.,flx_y(i,j,k)) - min(0.,flx_y(i,j+1,k)) &
					        + ( max(0.,flx_z(i,j,k)) - min(0.,flx_z(i,j,k+1)))*iadz(k) )*irho(k) + eps )
				enddo
			enddo
		enddo

		! Limit
		do k = MAX(1,z1), MIN(z2,nzm)
			do j = 1, ny
				do i = 1, nxp1
					flx_x(i,j,k) = max( 0., flx_x(i,j,k) ) * min( 1., mn(i-1,j,k), mx(i,j,k) ) &
					             + min( 0., flx_x(i,j,k) ) * min( 1., mn(i,j,k), mx(i-1,j,k) )
				enddo
			enddo

			do j = 1, nyp1
				do i = 1, nx
					flx_y(i,j,k) = max( 0., flx_y(i,j,k) ) * min( 1., mn(i,j-1,k), mx(i,j,k) ) &
					             + min( 0., flx_y(i,j,k) ) * min( 1., mn(i,j,k), mx(i,j-1,k) )
				enddo
			enddo
		enddo
		do k = MAX(2,z1), MIN(nzm,z2)
			do j = 1, ny
				do i = 1, nx
					flx_z(i,j,k) = max( 0., flx_z(i,j,k) ) * min( 1., mn(i,j,k-1), mx(i,j,k) ) &
					             + min( 0., flx_z(i,j,k) ) * min( 1., mn(i,j,k), mx(i,j,k-1) )
				enddo
			enddo
		enddo

		! Final update
		do k = MAX(1,z1), MIN(z2,nzm)
			do j = 1, ny
				do i = 1, nx
					f(i,j,k) = f(i,j,k) &
						+ ( flx_x(i,j,k) - flx_x(i+1,j,k) + flx_y(i,j,k) - flx_y(i,j+1,k) &
						+ ( flx_z(i,j,k) - flx_z(i,j,k+1) ) * iadz(k) ) * irho(k)
					flux(k) = flux(k) + flx_z(i,j,k)
				enddo
			enddo
		enddo

	end subroutine fct3D

	!--------------------------------------------------------------------------------------------------

	subroutine fct2D( f, u, w, flux, z1, z2 )

		! Flux corrected transport to enforce monotonicity
		! input: u, w: mass weighted courant number

		use grid
		implicit none

		! input & output
		real, dimension(dimx1_s:dimx2_s, dimy1_s:dimy2_s, nzm), intent(inout) :: f

		! input
                integer, intent(in) :: z1, z2
		real, dimension(dimx1_u:dimx2_u, dimy1_u:dimy2_u, nzm), intent(in) :: u
		real, dimension(dimx1_w:dimx2_w, dimy1_w:dimy2_w, nz ), intent(in) :: w

		! input & output
		real, dimension(nz), intent(out) :: flux

		! local
		real, dimension(-1:nxp3, nzm) :: flx_x
		real, dimension(-1:nxp2, nz ) :: flx_z
		real, dimension(0:nxp1, nzm) :: mn, mx
		integer :: i, k, km1, kp1
		real, parameter :: eps = 1.e-10

		! Set bottom and top vertical flux zero, also horizontal sum of vertical flux for output
		flx_z(:,1:z1)  = 0.
		flx_z(:,z2:nz) = 0.
		flux(:) = 0.

		! min and max bounds with f
		do k = MAX(1,z1), MIN(z2,nzm)
			km1 = max(1,k-1)
			kp1 = min(k+1,nzm)
			do i = 0, nxp1
				mn(i,k) = min( f(i,1,k), f(i-1,1,k), f(i+1,1,k), f(i,1,km1), f(i,1,kp1) )
				mx(i,k) = max( f(i,1,k), f(i-1,1,k), f(i+1,1,k), f(i,1,km1), f(i,1,kp1) )
			enddo
		enddo

		! 1st order upwind face value and residual higher-order flux
		do k = MAX(1,z1), MIN(z2,nzm)
			do i = -1, nxp3
				flx_x(i,k) = f(i-1,1,k) * max( 0., u(i,1,k) ) + f(i,1,k) * min( 0., u(i,1,k) )
			enddo
		enddo
		do k = MAX(2,z1), MIN(nzm,z2)
			do i = -1, nxp2
				flx_z(i,k) = f(i,1,k-1) * max( 0., w(i,1,k) ) + f(i,1,k) * min( 0., w(i,1,k) )
			enddo
		enddo

		! 1st order upwind update value
		do k = MAX(1,z1), MIN(z2,nzm)
			do i = -1, nxp2
				f(i,1,k) = f(i,1,k) + ( flx_x(i,k) - flx_x(i+1,k) &
				                    + ( flx_z(i,k) - flx_z(i,k+1) ) * iadz(k) ) * irho(k)
			enddo
			do i = 1, nx
				flux(k) = flux(k) + flx_z(i,k)
			enddo
		enddo

		! Antidiffusive flux
		do k = MAX(1,z1), MIN(z2,nzm)
			do i = 0, nxp2
				flx_x(i,k) = u(i,1,k) * fx(i,1,k) - flx_x(i,k)
			enddo
		enddo
		do k = MAX(2,z1), MIN(nzm,z2)
			do i = 0, nxp1
				flx_z(i,k) = w(i,1,k) * fz(i,1,k) - flx_z(i,k)
			enddo
		enddo

		! min and max bounds
		! Convert mn and mx to outflow and inflow fct scale factor
		do k = MAX(1,z1), MIN(z2,nzm)
			km1 = max(1,k-1)
			kp1 = min(k+1,nzm)
			do i = 0, nxp1
				mn(i,k) = min( f(i,1,k), f(i-1,1,k), f(i+1,1,k), f(i,1,km1), f(i,1,kp1), mn(i,k) )
				mx(i,k) = max( f(i,1,k), f(i-1,1,k), f(i+1,1,k), f(i,1,km1), f(i,1,kp1), mx(i,k) )

				! total higher-order outflow flux
				! outflow fct factor
				mn(i,k) = ( f(i,1,k) - mn(i,k) ) / ( ( max( 0., flx_x(i+1,k) ) - min( 0., flx_x(i,k) ) &
				   + ( max( 0., flx_z(i,k+1) ) - min( 0., flx_z(i,k) ) ) * iadz(k) + eps ) * irho(k) )

				! total higher-order inflow flux
				! inflow fct factor
				mx(i,k) = ( mx(i,k) - f(i,1,k) ) / ( ( max( 0., flx_x(i,k) ) - min( 0., flx_x(i+1,k) ) &
				   + ( max( 0., flx_z(i,k) ) - min( 0., flx_z(i,k+1) ) ) * iadz(k) + eps ) * irho(k) )
			enddo
		enddo

		! Limit
		do k = MAX(1,z1), MIN(z2,nzm)
			do i = 1, nxp1
				flx_x(i,k) = max( 0., flx_x(i,k) ) * min( 1., mn(i-1,k), mx(i,k) ) &
				           + min( 0., flx_x(i,k) ) * min( 1., mn(i,k), mx(i-1,k) )
			enddo
		enddo
		do k = MAX(2,z1), MIN(nzm,z2)
			do i = 1, nx
				flx_z(i,k) = max( 0., flx_z(i,k) ) * min( 1., mn(i,k-1), mx(i,k) ) &
				           + min( 0., flx_z(i,k) ) * min( 1., mn(i,k), mx(i,k-1) )
			enddo
		enddo

		! Final updatex
		do k = MAX(1,z1), MIN(z2,nzm)
			do i = 1, nx
				f(i,1,k) = f(i,1,k) + ( flx_x(i,k) - flx_x(i+1,k) &
				                    + ( flx_z(i,k) - flx_z(i,k+1) ) * iadz(k) ) * irho(k)
				flux(k) = flux(k) + flx_z(i,k)
			enddo
		enddo

	end subroutine fct2D

	!--------------------------------------------------------------------------------------------------

end module advect_um_lib


      subroutine qk15i(f,boun,inf,a,b,result,abserr,resabs,resasc)
c***begin prologue  qk15i
c***date written   800101   (yymmdd)
c***revision date  830518   (yymmdd)
c***category no.  h2a3a2,h2a4a2
c***keywords  15-point transformed gauss-kronrod rules
c***author  piessens,robert,appl. math. & progr. div. - k.u.leuven
c           de doncker,elise,appl. math. & progr. div. - k.u.leuven
c***purpose  the original (infinite integration range is mapped
c            onto the interval (0,1) and (a,b) is a part of (0,1).
c            it is the purpose to compute
c            i = integral of transformed integrand over (a,b),
c            j = integral of abs(transformed integrand) over (a,b).
c***description
c
c           integration rule
c           standard fortran subroutine
c           real version
c
c           parameters
c            on entry
c              f      - real
c                       fuction subprogram defining the integrand
c                       function f(x). the actual name for f needs to be
c                       declared e x t e r n a l in the calling program.
c
c              boun   - real
c                       finite bound of original integration
c                       range (set to zero if inf = +2)
c
c              inf    - integer
c                       if inf = -1, the original interval is
c                                   (-infinity,bound),
c                       if inf = +1, the original interval is
c                                   (bound,+infinity),
c                       if inf = +2, the original interval is
c                                   (-infinity,+infinity) and
c                       the integral is computed as the sum of two
c                       integrals, one over (-infinity,0) and one over
c                       (0,+infinity).
c
c              a      - real
c                       lower limit for integration over subrange
c                       of (0,1)
c
c              b      - real
c                       upper limit for integration over subrange
c                       of (0,1)
c
c            on return
c              result - real
c                       approximation to the integral i
c                       result is computed by applying the 15-point
c                       kronrod rule(resk) obtained by optimal addition
c                       of abscissae to the 7-point gauss rule(resg).
c
c              abserr - real
c                       estimate of the modulus of the absolute error,
c                       which should equal or exceed abs(i-result)
c
c              resabs - real
c                       approximation to the integral j
c
c              resasc - real
c                       approximation to the integral of
c                       abs((transformed integrand)-i/(b-a)) over (a,b)
c
c***references  (none)
c***routines called  r1mach
c***end prologue  qk15i
c
      real a,absc,absc1,absc2,abserr,b,boun,centr,
     *  dinf,r1mach,epmach,f,fc,fsum,fval1,fval2,fv1,
     *  fv2,hlgth,resabs,resasc,resg,resk,reskh,result,tabsc1,tabsc2,
     *  uflow,wg,wgk,xgk
      integer inf,j,min0
      external f
c
      dimension fv1(7),fv2(7),xgk(8),wgk(8),wg(8)
c
c           the abscissae and weights are supplied for the interval
c           (-1,1).  because of symmetry only the positive abscissae and
c           their corresponding weights are given.
c
c           xgk    - abscissae of the 15-point kronrod rule
c                    xgk(2), xgk(4), ... abscissae of the 7-point
c                    gauss rule
c                    xgk(1), xgk(3), ...  abscissae which are optimally
c                    added to the 7-point gauss rule
c
c           wgk    - weights of the 15-point kronrod rule
c
c           wg     - weights of the 7-point gauss rule, corresponding
c                    to the abscissae xgk(2), xgk(4), ...
c                    wg(1), wg(3), ... are set to zero.
c
      data xgk(1),xgk(2),xgk(3),xgk(4),xgk(5),xgk(6),xgk(7),
     *  xgk(8)/
     *     0.9914553711208126e+00,     0.9491079123427585e+00,
     *     0.8648644233597691e+00,     0.7415311855993944e+00,
     *     0.5860872354676911e+00,     0.4058451513773972e+00,
     *     0.2077849550078985e+00,     0.0000000000000000e+00/
c
      data wgk(1),wgk(2),wgk(3),wgk(4),wgk(5),wgk(6),wgk(7),
     *  wgk(8)/
     *     0.2293532201052922e-01,     0.6309209262997855e-01,
     *     0.1047900103222502e+00,     0.1406532597155259e+00,
     *     0.1690047266392679e+00,     0.1903505780647854e+00,
     *     0.2044329400752989e+00,     0.2094821410847278e+00/
c
      data wg(1),wg(2),wg(3),wg(4),wg(5),wg(6),wg(7),wg(8)/
     *     0.0000000000000000e+00,     0.1294849661688697e+00,
     *     0.0000000000000000e+00,     0.2797053914892767e+00,
     *     0.0000000000000000e+00,     0.3818300505051189e+00,
     *     0.0000000000000000e+00,     0.4179591836734694e+00/
c
c
c           list of major variables
c           -----------------------
c
c           centr  - mid point of the interval
c           hlgth  - half-length of the interval
c           absc*  - abscissa
c           tabsc* - transformed abscissa
c           fval*  - function value
c           resg   - result of the 7-point gauss formula
c           resk   - result of the 15-point kronrod formula
c           reskh  - approximation to the mean value of the transformed
c                    integrand over (a,b), i.e. to i/(b-a)
c
c           machine dependent constants
c           ---------------------------
c
c           epmach is the largest relative spacing.
c           uflow is the smallest positive magnitude.
c
c***first executable statement  qk15i
      epmach = r1mach(4)
      uflow = r1mach(1)
      dinf = min0(1,inf)
c
      centr = 0.5e+00*(a+b)
      hlgth = 0.5e+00*(b-a)
      tabsc1 = boun+dinf*(0.1e+01-centr)/centr
      fval1 = f(tabsc1)
      if(inf.eq.2) fval1 = fval1+f(-tabsc1)
      fc = (fval1/centr)/centr
c
c           compute the 15-point kronrod approximation to
c           the integral, and estimate the error.
c
      resg = wg(8)*fc
      resk = wgk(8)*fc
      resabs = abs(resk)
      do 10 j=1,7
        absc = hlgth*xgk(j)
        absc1 = centr-absc
        absc2 = centr+absc
        tabsc1 = boun+dinf*(0.1e+01-absc1)/absc1
        tabsc2 = boun+dinf*(0.1e+01-absc2)/absc2
        fval1 = f(tabsc1)
        fval2 = f(tabsc2)
        if(inf.eq.2) fval1 = fval1+f(-tabsc1)
        if(inf.eq.2) fval2 = fval2+f(-tabsc2)
        fval1 = (fval1/absc1)/absc1
        fval2 = (fval2/absc2)/absc2
        fv1(j) = fval1
        fv2(j) = fval2
        fsum = fval1+fval2
        resg = resg+wg(j)*fsum
        resk = resk+wgk(j)*fsum
        resabs = resabs+wgk(j)*(abs(fval1)+abs(fval2))
   10 continue
      reskh = resk*0.5e+00
      resasc = wgk(8)*abs(fc-reskh)
      do 20 j=1,7
        resasc = resasc+wgk(j)*(abs(fv1(j)-reskh)+abs(fv2(j)-reskh))
   20 continue
      result = resk*hlgth
      resasc = resasc*hlgth
      resabs = resabs*hlgth
      abserr = abs((resk-resg)*hlgth)
      if(resasc.ne.0.0e+00.and.abserr.ne.0.e0) abserr = resasc*
     * amin1(0.1e+01,(0.2e+03*abserr/resasc)**1.5e+00)
      if(resabs.gt.uflow/(0.5e+02*epmach)) abserr = amax1
     * ((epmach*0.5e+02)*resabs,abserr)
      return
      end


!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of rhocm in forward (tangent) mode:
!   variations   of useful results: rhocm
!   with respect to varying inputs: *temp *propunit
!   Plus diff mem management of: temp:in propunit:in
! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!>    @brief calculates product of heat capacity and density of rock.
!>    @param[in] i cell index, direction I0
!>    @param[in] j cell index, direction J0
!>    @param[in] k cell index, direction K0
!>    @param[in] ismpl local sample index
!>    @return  rhocm                                rc   [J / (m^3 K)]
!>    @details
!>    input:\n
!>      pressure                            plocal [Mpa]\n
!>      temperature                         tlocal in [C]\n
DOUBLE PRECISION FUNCTION g_RHOCM(i, j, k, ismpl, rhocm)
  USE ARRAYS

  USE g_ARRAYS

  USE MOD_TEMP
  IMPLICIT NONE
  INTEGER :: i, j, k, ismpl
  DOUBLE PRECISION :: plocal, tlocal
  DOUBLE PRECISION :: g_tlocal
  DOUBLE PRECISION :: temp0
  DOUBLE PRECISION :: temp1
  DOUBLE PRECISION :: rhocm
  g_tlocal = g_temp(i, j, k, ismpl)
  tlocal = temp(i, j, k, ismpl)
  temp0 = cma1 + cma2*tlocal + cma3*(tlocal*tlocal)
  temp1 = propunit(uindex(i, j, k), idx_rc, ismpl)
  g_rhocm = temp0*g_propunit(uindex(i, j, k), idx_rc, ismpl) + temp1&
&   *(cma2+cma3*2*tlocal)*g_tlocal
  rhocm = temp1*temp0
  RETURN
END FUNCTION g_RHOCM


!======================================================================================================================
!> @file        solve_theta_plan_many.f90
!> @brief       This file contains a solver subroutine for the example problem of PaScaL_TDMA.
!> @details     The target example problem is the three-dimensional time-dependent heat conduction problem
!>              in a unit cube domain applied with the boundary conditions of vertically constant temperature
!>              and horizontally periodic boundaries.
!> @author
!>              - Kiha Kim (k-kiha@yonsei.ac.kr), Department of Computational Science & Engineering, Yonsei University
!>              - Ji-Hoon Kang (jhkang@kisti.re.kr), Korea Institute of Science and Technology Information
!>              - Jung-Il Choi (jic@yonsei.ac.kr), Department of Computational Science & Engineering, Yonsei University
!>
!> @date        June 2019
!> @version     1.0
!> @par         Copyright
!>              Copyright (c) 2019 Kiha Kim and Jung-Il choi, Yonsei University and
!>              Ji-Hoon Kang, Korea Institute of Science and Technology Information, All rights reserved.
!> @par         License
!>              This project is release under the terms of the MIT License (see LICENSE in )
!======================================================================================================================

!>
!> @brief       An example solver for many tridiagonal systems of equations using PaScaL_TDMA.
!> @details     This subroutine is for many tridiagonal systems of equations.
!>              It solves the the three-dimensional time-dependent heat conduction problem using PaScaL_TDMA.
!>              PaScaL_TDMA plans are created for many tridiagonal systems of equations and
!>              the many tridiagonal systems are solved plane-by-plane.
!> @param       theta       Main 3-D variable to be solved
!>
subroutine solve_theta_plan_many(theta)
    use mpi
    use global
    use mpi_subdomain
    use mpi_topology
    use PaScaL_TDMA
    implicit none
    double precision, dimension(0:nx_sub, 0:ny_sub, 0:nz_sub), intent(inout) :: theta

    ! Loop and index variables
    integer :: i,j,k
    integer :: ip, jp, kp
    integer :: im, jm, km
    integer :: jem, jep

    ! Temporary variables for coefficient computations
    double precision :: dedx1, dedx2, dedy3, dedy4, dedz5, dedz6    ! Derivative terms
    double precision :: viscous_e1, viscous_e2, viscous_e3, viscous ! Viscous terms
    double precision :: ebc_down, ebc_up, ebc                       ! Boundary terms
    double precision :: eAPI, eAMI, eACI                            ! Diffusion treatment terms in x-direction
    double precision :: eAPJ, eAMJ, eACJ                            ! Diffusion treatment terms in y-direction
    double precision :: eAPK, eAMK, eACK                            ! Diffusion treatment terms in z-direction
    double precision :: eRHS                                        ! From eAPI to eACK

    double precision, allocatable, dimension(:, :, :) :: rhs            ! r.h.s. array
    double precision, allocatable, dimension(:, :) :: ap, am, ac, ad    ! Coefficient of ridiagonal matrix

    type(ptdma_plan_many)     :: px_many, py_many, pz_many          ! Plan for many tridiagonal systems of equations

    ! Calculating r.h.s.
    allocate( rhs(0:nx_sub, 0:ny_sub, 0:nz_sub))
    do k = 1, nz_sub-1
        kp = k+1
        km = k-1

        do j = 1, ny_sub-1
            jp = j + 1
            jm = j - 1
            jep = jpbc_index(j)
            jem = jmbc_index(j)

            do i = 1, nx_sub-1
                ip = i+1
                im = i-1

                ! Diffusion term
                dedx1 = (  theta(i ,j ,k ) - theta(im,j ,k )  )/dmx_sub(i )
                dedx2 = (  theta(ip,j ,k ) - theta(i ,j ,k )  )/dmx_sub(ip)
                dedy3 = (  theta(i ,j ,k ) - theta(i ,jm,k )  )/dmy_sub(j )
                dedy4 = (  theta(i ,jp,k ) - theta(i ,j ,k )  )/dmy_sub(jp)
                dedz5 = (  theta(i ,j ,k ) - theta(i ,j ,km)  )/dmz_sub(k )
                dedz6 = (  theta(i ,j ,kp) - theta(i ,j ,k )  )/dmz_sub(kp)

                viscous_e1 = 1.d0/dx*(dedx2 - dedx1)
                viscous_e2 = 1.d0/dy*(dedy4 - dedy3)
                viscous_e3 = 1.d0/dz*(dedz6 - dedz5)
                viscous = 0.5d0*Ct*(viscous_e1 + viscous_e2 + viscous_e3)

                ! Boundary treatment for the y-direction only
                ebc_down = 0.5d0*Ct/dy/dmy_sub(j)*thetaBC3_sub(i,k)
                ebc_up = 0.5d0*Ct/dy/dmy_sub(jp)*thetaBC4_sub(i,k)
                ebc = dble(1. - jem)*ebc_down + dble(1. - jep)*ebc_up

                ! Diffusion term from incremental notation in next time step: x-direction
                eAPI = -0.5d0*Ct/dx/dmx_sub(ip)
                eAMI = -0.5d0*Ct/dx/dmx_sub(i )
                eACI =  0.5d0*Ct/dx*( 1.d0/dmx_sub(ip) + 1.d0/dmx_sub(i) )

                ! Diffusion term from incremental notation in next time step: z-direction
                eAPK = -0.5d0*Ct/dz/dmz_sub(kp)
                eAMK = -0.5d0*Ct/dz/dmz_sub(k )
                eACK =  0.5d0*Ct/dz*( 1.d0/dmz_sub(kp) + 1.d0/dmz_sub(k) )

                ! Diffusion term from incremental notation in next time step: y-direction
                eAPJ = -0.5d0*Ct/dy*( 1.d0/dmy_sub(jp) )*dble(jep)
                eAMJ = -0.5d0*Ct/dy*( 1.d0/dmy_sub(j ) )*dble(jem)
                eACJ =  0.5d0*Ct/dy*( 1.d0/dmy_sub(jp) + 1.d0/dmy_sub(j) )

                eRHS = eAPK*theta(i,j,kp) + eACK*theta(i,j,k) + eAMK*theta(i,j,km)      &
                    & + eAPJ*theta(i,jp,k) + eACJ*theta(i,j,k) + eAMJ*theta(i,jm,k)      &
                    & + eAPI*theta(ip,j,k) + eACI*theta(i,j,k) + eAMI*theta(im,j,k)

                ! r.h.s. term
                rhs(i,j,k) = theta(i,j,k)/dt + viscous + ebc      &
                          & - (theta(i,j,k)/dt + eRHS)
            enddo
        enddo
    enddo

    ! solve in the z-direction.
    allocate( ap(1:nx_sub-1, 1:nz_sub-1), am(1:nx_sub-1, 1:nz_sub-1), ac(1:nx_sub-1, 1:nz_sub-1), ad(1:nx_sub-1, 1:nz_sub-1) )

    ! Create a PaScaL_TDMA plan for the tridiagonal systems.
    call PaScaL_TDMA_plan_many_create(pz_many, nx_sub-1, comm_1d_z%myrank, comm_1d_z%nprocs, comm_1d_z%mpi_comm)

    ! Build a coefficient matrix for the tridiagonal systems into a 2D array.
    do j = 1, ny_sub-1
        do k = 1, nz_sub-1
            kp = k+1
            do i = 1, nx_sub-1
                ap(i,k) = -0.5d0*Ct/dz/dmz_sub(kp)*dt
                am(i,k) = -0.5d0*Ct/dz/dmz_sub(k )*dt
                ac(i,k) =  0.5d0*Ct/dz*( 1.d0/dmz_sub(kp) + 1.d0/dmz_sub(k) )*dt + 1.d0

                ad(i,k) = rhs(i,j,k)*dt
            enddo
        enddo

        ! Solve the tridiagonal systems under the defined plan with periodic boundary conditions.
        call PaScaL_TDMA_many_solve_cycle(pz_many, am, ac, ap, ad,nx_sub-1,nz_sub-1)

        ! Return the solution to the r.h.s. plane-by-plane
        do k = 1, nz_sub-1
            rhs(1:nx_sub-1,j,k)=ad(1:nx_sub-1,k)
        enddo
    enddo

    ! Destroy the PaScaL_TDMA plan for the tridiagonal systems.
    call PaScaL_TDMA_plan_many_destroy(pz_many,comm_1d_z%nprocs)
    deallocate( ap, am, ac, ad )

    ! solve in the x-direction.
    allocate( ap(1:nx_sub-1, 1:ny_sub-1), am(1:nx_sub-1, 1:ny_sub-1), ac(1:nx_sub-1, 1:ny_sub-1), ad(1:nx_sub-1, 1:ny_sub-1) )

    ! Create a PaScaL_TDMA plan for the tridiagonal systems.
    call PaScaL_TDMA_plan_many_create(py_many, nx_sub-1, comm_1d_y%myrank, comm_1d_y%nprocs, comm_1d_y%mpi_comm)

    ! Build a coefficient matrix for the tridiagonal systems into a 2D array.
    do k = 1, nz_sub-1
        do j = 1, ny_sub-1
            jp = j + 1
            jm = j - 1
            jep = jpbc_index(j)
            jem = jmbc_index(j)

            do i = 1, nx_sub-1
                ap(i,j) = -0.5d0*Ct/dy/dmy_sub(jp)*dble(jep)*dt
                am(i,j) = -0.5d0*Ct/dy/dmy_sub(j )*dble(jem)*dt
                ac(i,j) =  0.5d0*Ct/dy*( 1.d0/dmy_sub(jp) + 1.d0/dmy_sub(j) )*dt + 1.d0
                ad(i,j) = rhs(i,j,k)
            end do
        end do

        ! Solve the tridiagonal systems under the defined plan.
        call PaScaL_TDMA_many_solve(py_many, am, ac, ap, ad, nx_sub-1, ny_sub-1)

        ! Return the solution to the r.h.s. plane-by-plane.
        do j = 1, ny_sub-1
            rhs(1:nx_sub-1,j,k)=ad(1:nx_sub-1,j)
        enddo
    end do
    call PaScaL_TDMA_plan_many_destroy(py_many,comm_1d_y%nprocs)
    deallocate( ap, am, ac, ad )

    ! solve in the y-direction.
    allocate( ap(1:ny_sub-1, 1:nx_sub-1), am(1:ny_sub-1, 1:nx_sub-1), ac(1:ny_sub-1, 1:nx_sub-1), ad(1:ny_sub-1, 1:nx_sub-1) )

    ! Create a PaScaL_TDMA plan for the tridiagonal systems.
    call PaScaL_TDMA_plan_many_create(px_many, ny_sub-1, comm_1d_x%myrank, comm_1d_x%nprocs, comm_1d_x%mpi_comm)

    ! Build a coefficient matrix for the tridiagonal systems into a 2D array.
    do k = 1, nz_sub-1
        do j = 1, ny_sub-1
            do i = 1, nx_sub-1
                ip = i+1
                im = i-1

                ap(j,i) = -0.5d0*Ct/dx/dmx_sub(ip)*dt
                am(j,i) = -0.5d0*Ct/dx/dmx_sub(i )*dt
                ac(j,i) =  0.5d0*Ct/dx*( 1.d0/dmx_sub(ip) + 1.d0/dmx_sub(i) )*dt + 1.d0
                ad(j,i) = rhs(i,j,k)
            enddo
        enddo
        ! Solve the tridiagonal systems under the defined plan with periodic boundary conditions.
        call PaScaL_TDMA_many_solve_cycle(px_many, am, ac, ap, ad, ny_sub-1, nx_sub-1)

        ! Return the solution to theta plane-by-plane.
        do j = 1, ny_sub-1
            theta(1:nx_sub-1,j,k) = theta(1:nx_sub-1,j,k) + ad(j,1:nx_sub-1)
        enddo

    enddo
    call PaScaL_TDMA_plan_many_destroy(px_many,comm_1d_x%nprocs)
    deallocate( ap, am, ac, ad )

    deallocate(rhs)

    ! Update ghostcells from the solution.
    call mpi_subdomain_ghostcell_update(theta, comm_1d_x, comm_1d_y, comm_1d_z)

end subroutine solve_theta_plan_many


      INTEGER FUNCTION ILACLC(M, N, A, LDA)
      IMPLICIT NONE
!
!  -- LAPACK auxiliary routine (version 3.2) --
!     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
!     December 2007
!
!     .. Scalar Arguments ..
      INTEGER            M, N, LDA
!     ..
!     .. Array Arguments ..
      COMPLEX            A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  ILACLC scans A for its last non-zero column.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.
!
!  A       (input) COMPLEX array, dimension (LDA,N)
!          The m by n matrix A.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A. LDA >= max(1,M).
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX          ZERO
      PARAMETER ( ZERO = (0.0E+0, 0.0E+0) )
!     ..
!     .. Local Scalars ..
      INTEGER I
!     ..
!     .. Executable Statements ..
!
!     Quick test for the common case where one corner is non-zero.
      IF( N.EQ.0 .OR. A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
         ILACLC = N
      ELSE
!     Now scan each column from the end, returning with the first non-zero.
         DO ILACLC = N, 1, -1
            DO I = 1, M
               IF( A(I, ILACLC).NE.ZERO ) RETURN
            END DO
         END DO
      END IF
      RETURN
      END FUNCTION


! This example maps over an entire array to the GPU, then launches kernels to update sections of the array.
! It uses target update on those sections as each kernel finishes.
!
! This variant places the array inside a derived type.
program map_array_slices_in_type
   implicit none

   integer i, j, num_slices, num_values, a

   type daxpy_data
      real, pointer, contiguous, dimension(:,:) :: x, y
      integer :: a, b, c, d, e, f = 1
      real :: g, h, i, j, k, l = 1.0
   end type daxpy_data

   type(daxpy_data), pointer :: the_data

   a = 5
   num_slices = 10
   num_values = 1024

   allocate(the_data)
   allocate(the_data%x(num_values,num_slices))
   allocate(the_data%y(num_values,num_slices))

   ! initialize arrays
   print *, "----------"
   do j = 1, num_slices
      the_data%x(:,j) = DBLE(j)
      the_data%y(:,j) = DBLE(j)
      print *, "before x(1:10,", j, ") ", the_data%x(1:10,j)
   end do
   print *, "----------"

   !$omp target data map(to:the_data)

   !$omp parallel do
   do j = 1, num_slices

! Map and work on slice

      !$omp target teams distribute parallel do private(i) shared(a, the_data, j, num_values) map(tofrom:the_data%x(:,j)) map(to:the_data%y(:,j)) default(none)
      do i = 1, num_values
         the_data%x(i,j) = a*the_data%x(i,j) + the_data%y(i,j)
      end do
      !$omp end target teams distribute parallel do

      print *, "Ran daxpy on slice ", j

   end do
!$omp end parallel do

!$omp end target data
   print *, "----------"
   do j = 1, num_slices
      print *, "after x(1:10,", j, ") ", the_data%x(1:10,j)
   end do
   print *, "----------"

end program map_array_slices_in_type


c                             DRIVER 1
c     --------------------------------------------------------------
c                SIMPLE DRIVER FOR L-BFGS-B (version 2.3)
c     --------------------------------------------------------------
c
c        L-BFGS-B is a code for solving large nonlinear optimization
c        problems with simple bounds on the variables.
c
c        The code can also be used for unconstrained problems and is
c        as efficient for these problems as the earlier limited memory
c        code L-BFGS.
c
c        This is the simplest driver in the package. It uses all the
c        default settings of the code.
c
c
c     References:
c
c        [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited
c        memory algorithm for bound constrained optimization'',
c        SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208.
c
c        [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: FORTRAN
c        Subroutines for Large Scale Bound Constrained Optimization''
c        Tech. Report, NAM-11, EECS Department, Northwestern University,
c        1994.
c
c        (Postscript files of these papers are available via anonymous
c        ftp to ece.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.)
c
c                              *  *  *
c
c        NEOS, November 1994. (Latest revision April 1997.)
c        Optimization Technology Center.
c        Argonne National Laboratory and Northwestern University.
c        Written by
c                           Ciyou Zhu
c        in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal.

      program driver1

      use solver_lbfgsb, only : setulb

      implicit none

c     This simple driver demonstrates how to call the L-BFGS-B code to
c     solve a sample problem (the extended Rosenbrock function
c     subject to bounds on the variables). The dimension n of this
c     problem is variable.

      integer          nmax, mmax, lenwa
      parameter       (nmax  = 1024, mmax = 17)
      parameter       (lenwa = 2*mmax*nmax +  4*nmax
     +                      + 11*mmax*mmax + 8*mmax)

c     nmax  is the dimension of the largest problem to be solved.
c     mmax  is the maximum number of limited memory corrections.
c     lenwa is the corresponding real workspace required.

c     Declare the variables needed by the code.
c     A description of all these variables is given at the end of
c     the driver.

      character*60     task, csave
      logical          lsave(4)
      integer          n, m, iprint,
     +                 nbd(nmax), iwa(3*nmax), isave(44)
      double precision f, factr, pgtol,
     +                 x(nmax), l(nmax), u(nmax), g(nmax), dsave(29),
     +                 wa(lenwa)

c     Declare a few additional variables for this sample problem.

      double precision t1, t2
      integer          i

c     We wish to have output at every iteration.

      iprint = 1

c     We specify the tolerances in the stopping criteria.

      factr  = 1.0d+7
      pgtol  = 1.0d-5

c     We specify the dimension n of the sample problem and the number
c     m of limited memory corrections stored.  (n and m should not
c     exceed the limits nmax and mmax respectively.)

      n      = 25
      m      =  5

c     We now provide nbd which defines the bounds on the variables:
c     l   specifies the lower bounds,
c     u   specifies the upper bounds.

c     First set bounds on the odd-numbered variables.

      do i = 1, n, 2
         nbd(i) = 2
         l(i)   = 1.0d0
         u(i)   = 1.0d2
      end do

c     Next set bounds on the even-numbered variables.

      do i = 2, n, 2
         nbd(i) = 2
         l(i)   =-1.0d2
         u(i)   = 1.0d2
      end do

c     We now define the starting point.

      do i = 1, n
         x(i) = 3.0d0
      end do

c     We now write the heading of the output.

      write (6,16)
   16 format(/ 5x, 'Solving sample problem.'
     +       / 5x, ' (f = 0.0 at the optimal solution.)' /)

c     We start the iteration by initializing task.

      task = 'START'

c     ------- The beginning of the loop ----------
      main : do

c     This is the call to the L-BFGS-B code.

      call setulb(n,m,x,l,u,nbd,f,g,factr,pgtol,wa,iwa,task,iprint,
     +            csave,lsave,isave,dsave)

      if (task(1:2) .eq. 'FG') then

c        The minimization routine has returned to request the
c        function f and gradient g values at the current x.

c        Compute function value f for the sample problem.

         f = .25d0*(x(1) - 1.d0)**2
         do i = 2, n
            f = f + (x(i) - x(i-1)**2)**2
         end do
         f = 4.d0*f

c        Compute gradient g for the sample problem.

         t1   = x(2) - x(1)**2
         g(1) = 2.d0*(x(1) - 1.d0) - 1.6d1*x(1)*t1
         do i = 2, n-1
            t2   = t1
            t1   = x(i+1) - x(i)**2
            g(i) = 8.d0*t2 - 1.6d1*x(i)*t1
         end do
         g(n) = 8.d0*t1

c        Go back to the minimization routine.

      elseif (task(1:5) .eq. 'NEW_X') then

c        The minimization routine has returned with a new iterate,
c        and we have opted to continue the iteration.

      else

c        We terminate execution when task is neither FG nor NEW_X.
c        We print the information contained in the string task
c        if the default output is not used and the execution is
c        not stopped intentionally by the user.

         if (iprint .le. -1 .and. task(1:4) .ne. 'STOP') write(6,*) task
         exit main

      endif

      end do main

      end program driver1

c======================= The end of driver1 ============================

c     --------------------------------------------------------------
c             DESCRIPTION OF THE VARIABLES IN L-BFGS-B
c     --------------------------------------------------------------
c
c     n is an INTEGER variable that must be set by the user to the
c       number of variables.  It is not altered by the routine.
c
c     m is an INTEGER variable that must be set by the user to the
c       number of corrections used in the limited memory matrix.
c       It is not altered by the routine.  Values of m < 3  are
c       not recommended, and large values of m can result in excessive
c       computing time. The range  3 <= m <= 20 is recommended.
c
c     x is a DOUBLE PRECISION array of length n.  On initial entry
c       it must be set by the user to the values of the initial
c       estimate of the solution vector.  Upon successful exit, it
c       contains the values of the variables at the best point
c       found (usually an approximate solution).
c
c     l is a DOUBLE PRECISION array of length n that must be set by
c       the user to the values of the lower bounds on the variables. If
c       the i-th variable has no lower bound, l(i) need not be defined.
c
c     u is a DOUBLE PRECISION array of length n that must be set by
c       the user to the values of the upper bounds on the variables. If
c       the i-th variable has no upper bound, u(i) need not be defined.
c
c     nbd is an INTEGER array of dimension n that must be set by the
c       user to the type of bounds imposed on the variables:
c       nbd(i)=0 if x(i) is unbounded,
c              1 if x(i) has only a lower bound,
c              2 if x(i) has both lower and upper bounds,
c              3 if x(i) has only an upper bound.
c
c     f is a DOUBLE PRECISION variable.  If the routine setulb returns
c       with task(1:2)= 'FG', then f must be set by the user to
c       contain the value of the function at the point x.
c
c     g is a DOUBLE PRECISION array of length n.  If the routine setulb
c       returns with taskb(1:2)= 'FG', then g must be set by the user to
c       contain the components of the gradient at the point x.
c
c     factr is a DOUBLE PRECISION variable that must be set by the user.
c       It is a tolerance in the termination test for the algorithm.
c       The iteration will stop when
c
c        (f^k - f^{k+1})/max{|f^k|,|f^{k+1}|,1} <= factr*epsmch
c
c       where epsmch is the machine precision which is automatically
c       generated by the code. Typical values for factr on a computer
c       with 15 digits of accuracy in double precision are:
c       factr=1.d+12 for low accuracy;
c             1.d+7  for moderate accuracy;
c             1.d+1  for extremely high accuracy.
c       The user can suppress this termination test by setting factr=0.
c
c     pgtol is a double precision variable.
c       On entry pgtol >= 0 is specified by the user.  The iteration
c         will stop when
c
c                 max{|proj g_i | i = 1, ..., n} <= pgtol
c
c         where pg_i is the ith component of the projected gradient.
c       The user can suppress this termination test by setting pgtol=0.
c
c     wa is a DOUBLE PRECISION  array of length
c       (2mmax + 4)nmax + 11mmax^2 + 8mmax used as workspace.
c       This array must not be altered by the user.
c
c     iwa is an INTEGER  array of length 3nmax used as
c       workspace. This array must not be altered by the user.
c
c     task is a CHARACTER string of length 60.
c       On first entry, it must be set to 'START'.
c       On a return with task(1:2)='FG', the user must evaluate the
c         function f and gradient g at the returned value of x.
c       On a return with task(1:5)='NEW_X', an iteration of the
c         algorithm has concluded, and f and g contain f(x) and g(x)
c         respectively.  The user can decide whether to continue or stop
c         the iteration.
c       When
c         task(1:4)='CONV', the termination test in L-BFGS-B has been
c           satisfied;
c         task(1:4)='ABNO', the routine has terminated abnormally
c           without being able to satisfy the termination conditions,
c           x contains the best approximation found,
c           f and g contain f(x) and g(x) respectively;
c         task(1:5)='ERROR', the routine has detected an error in the
c           input parameters;
c       On exit with task = 'CONV', 'ABNO' or 'ERROR', the variable task
c         contains additional information that the user can print.
c       This array should not be altered unless the user wants to
c          stop the run for some reason.  See driver2 or driver3
c          for a detailed explanation on how to stop the run
c          by assigning task(1:4)='STOP' in the driver.
c
c     iprint is an INTEGER variable that must be set by the user.
c       It controls the frequency and type of output generated:
c        iprint<0    no output is generated;
c        iprint=0    print only one line at the last iteration;
c        0<iprint<99 print also f and |proj g| every iprint iterations;
c        iprint=99   print details of every iteration except n-vectors;
c        iprint=100  print also the changes of active set and final x;
c        iprint>100  print details of every iteration including x and g;
c       When iprint > 0, the file iterate.dat will be created to
c                        summarize the iteration.
c
c     csave  is a CHARACTER working array of length 60.
c
c     lsave is a LOGICAL working array of dimension 4.
c       On exit with task = 'NEW_X', the following information is
c         available:
c       lsave(1) = .true.  the initial x did not satisfy the bounds;
c       lsave(2) = .true.  the problem contains bounds;
c       lsave(3) = .true.  each variable has upper and lower bounds.
c
c     isave is an INTEGER working array of dimension 44.
c       On exit with task = 'NEW_X', it contains information that
c       the user may want to access:
c         isave(30) = the current iteration number;
c         isave(34) = the total number of function and gradient
c                         evaluations;
c         isave(36) = the number of function value or gradient
c                                  evaluations in the current iteration;
c         isave(38) = the number of free variables in the current
c                         iteration;
c         isave(39) = the number of active constraints at the current
c                         iteration;
c
c       See the subroutine setulb.f for a description of other
c       information contained in isave.
c
c     dsave is a DOUBLE PRECISION working array of dimension 29.
c       On exit with task = 'NEW_X', it contains information that
c       the user may want to access:
c         dsave(2) = the value of f at the previous iteration;
c         dsave(5) = the machine precision epsmch generated by the code;
c         dsave(13) = the infinity norm of the projected gradient;
c
c       See the subroutine setulb.f for a description of other
c       information contained in dsave.
c
c     --------------------------------------------------------------
c           END OF THE DESCRIPTION OF THE VARIABLES IN L-BFGS-B
c     --------------------------------------------------------------


! stat.f90
!
!>  Statistics accumulators
!
!> @copyright
!> 2015-2020 Lesley De Cruz & Jonathan Demaeyer.
!> See LICENSE.txt for license information.
!
!---------------------------------------------------------------------------!

MODULE stat
  IMPLICIT NONE

  PRIVATE

  !> Statistics accumulator objects class
  TYPE, PUBLIC :: StatAccumulator
    INTEGER :: i=0 !< Number of stats accumulated

    ! Vectors holding the stats
    REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: m       !< Vector storing the inline mean
    REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: mprev   !< Previous mean vector
    REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: v       !< Vector storing the inline variance
    REAL(KIND=8), DIMENSION(:), ALLOCATABLE :: mtmp
  CONTAINS
    PROCEDURE :: init => init_stat
    PROCEDURE :: accumulate => acc
    PROCEDURE :: mean
    PROCEDURE :: var
    PROCEDURE :: iter
    PROCEDURE :: reset
    PROCEDURE :: clean
  END TYPE StatAccumulator

  CONTAINS

    !> Initialize the accumulators
    !> @param[in,out] istat Statistical accumulator to initialize
    !> @param[in] ndim Dimension of the state space to accumulate statistics for.
    SUBROUTINE init_stat(istat, ndim)
      CLASS(StatAccumulator), INTENT(INOUT) :: istat
      INTEGER, INTENT(in) :: ndim
      INTEGER :: AllocStat

      ALLOCATE(istat%m(ndim), istat%mprev(ndim), STAT=AllocStat)
      IF (AllocStat /= 0) THEN
        PRINT*, "*** init_stat: Problem with allocation! ***"
        STOP "Exiting ..."
      END IF
      ALLOCATE(istat%v(ndim), istat%mtmp(ndim), STAT=AllocStat)
      IF (AllocStat /= 0) THEN
        PRINT*, "*** init_stat: Problem with allocation! ***"
        STOP "Exiting ..."
      END IF
      istat%m=0.D0
      istat%mprev=0.D0
      istat%v=0.D0
      istat%mtmp=0.D0

    END SUBROUTINE init_stat

    !> Accumulate one state
    !> @param[in,out] istat Statistical accumulator to initialize
    !> @param[in] x State to accumulate
    SUBROUTINE acc(istat, x)
      CLASS(StatAccumulator), INTENT(INOUT) :: istat
      REAL(KIND=8), DIMENSION(:), INTENT(IN) :: x
      istat%i=istat%i+1
      istat%mprev=istat%m+(x-istat%m)/istat%i
      istat%mtmp=istat%mprev
      istat%mprev=istat%m
      istat%m=istat%mtmp
      istat%v=istat%v+(x-istat%mprev)*(x-istat%m)
    END SUBROUTINE acc

    !> Function returning the mean
    !> @param[in,out] istat Statistical accumulator to initialize
    !> @return The mean of the accumulated states
    FUNCTION mean(istat)
      CLASS(StatAccumulator), INTENT(IN) :: istat
      REAL(KIND=8), DIMENSION(size(istat%m)) :: mean
      mean=istat%m
    END FUNCTION mean

    !> Function returning the variance
    !> @param[in,out] istat Statistical accumulator to initialize
    !> @return The variance of the accumulated states
    FUNCTION var(istat)
      CLASS(StatAccumulator), INTENT(IN) :: istat
      REAL(KIND=8), DIMENSION(size(istat%m)) :: var
      var=istat%v/(istat%i-1)
    END FUNCTION var

    !> Function returning the number of data accumulated
    !> @param[in,out] istat Statistical accumulator to initialize
    !> @return The number of the accumulated states
    FUNCTION iter(istat)
      CLASS(StatAccumulator), INTENT(IN) :: istat
      INTEGER :: iter
      iter=istat%i
    END FUNCTION iter

    !> Routine resetting the accumulator
    !> @param[in,out] istat Statistical accumulator to initialize
    SUBROUTINE reset(istat)
      CLASS(StatAccumulator), INTENT(INOUT) :: istat
      istat%m=0.D0
      istat%mprev=0.D0
      istat%v=0.D0
      istat%i=0
    END SUBROUTINE reset

  !> Routine to clean the accumulator
  !> @param[in,out] istat Statistical accumulator to clean
  SUBROUTINE clean(istat)
      CLASS(StatAccumulator), INTENT(INOUT) :: istat

      IF (allocated(istat%m)) DEALLOCATE(istat%m)
      IF (allocated(istat%mprev)) DEALLOCATE(istat%mprev)
      IF (allocated(istat%v)) DEALLOCATE(istat%v)
      IF (allocated(istat%mtmp)) DEALLOCATE(istat%mtmp)

  END SUBROUTINE clean

END MODULE stat