*> \brief \b ZLATME
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZLATME( N, DIST, ISEED, D, MODE, COND, DMAX,
*         RSIGN,
*                          UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM,
*         A,
*                          LDA, WORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          DIST, RSIGN, SIM, UPPER
*       INTEGER            INFO, KL, KU, LDA, MODE, MODES, N
*       DOUBLE PRECISION   ANORM, COND, CONDS
*       COMPLEX*16         DMAX
*       ..
*       .. Array Arguments ..
*       INTEGER            ISEED( 4 )
*       DOUBLE PRECISION   DS( * )
*       COMPLEX*16         A( LDA, * ), D( * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>    ZLATME generates random non-symmetric square matrices with
*>    specified eigenvalues for testing LAPACK programs.
*>
*>    ZLATME operates by applying the following sequence of
*>    operations:
*>
*>    1. Set the diagonal to D, where D may be input or
*>         computed according to MODE, COND, DMAX, and RSIGN
*>         as described below.
*>
*>    2. If UPPER='T', the upper triangle of A is set to random values
*>         out of distribution DIST.
*>
*>    3. If SIM='T', A is multiplied on the left by a random matrix
*>         X, whose singular values are specified by DS, MODES, and
*>         CONDS, and on the right by X inverse.
*>
*>    4. If KL < N-1, the lower bandwidth is reduced to KL using
*>         Householder transformations.  If KU < N-1, the upper
*>         bandwidth is reduced to KU.
*>
*>    5. If ANORM is not negative, the matrix is scaled to have
*>         maximum-element-norm ANORM.
*>
*>    (Note: since the matrix cannot be reduced beyond Hessenberg form,
*>     no packing options are available.)
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>           The number of columns (or rows) of A. Not modified.
*> \endverbatim
*>
*> \param[in] DIST
*> \verbatim
*>          DIST is CHARACTER*1
*>           On entry, DIST specifies the type of distribution to be used
*>           to generate the random eigen-/singular values, and on the
*>           upper triangle (see UPPER).
*>           'U' => UNIFORM( 0, 1 )  ( 'U' for uniform )
*>           'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
*>           'N' => NORMAL( 0, 1 )   ( 'N' for normal )
*>           'D' => uniform on the complex disc |z| < 1.
*>           Not modified.
*> \endverbatim
*>
*> \param[in,out] ISEED
*> \verbatim
*>          ISEED is INTEGER array, dimension ( 4 )
*>           On entry ISEED specifies the seed of the random number
*>           generator. They should lie between 0 and 4095 inclusive,
*>           and ISEED(4) should be odd. The random number generator
*>           uses a linear congruential sequence limited to small
*>           integers, and so should produce machine independent
*>           random numbers. The values of ISEED are changed on
*>           exit, and can be used in the next call to ZLATME
*>           to continue the same random number sequence.
*>           Changed on exit.
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*>          D is COMPLEX*16 array, dimension ( N )
*>           This array is used to specify the eigenvalues of A.  If
*>           MODE=0, then D is assumed to contain the eigenvalues
*>           otherwise they will be computed according to MODE, COND,
*>           DMAX, and RSIGN and placed in D.
*>           Modified if MODE is nonzero.
*> \endverbatim
*>
*> \param[in] MODE
*> \verbatim
*>          MODE is INTEGER
*>           On entry this describes how the eigenvalues are to
*>           be specified:
*>           MODE = 0 means use D as input
*>           MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND
*>           MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND
*>           MODE = 3 sets D(I)=COND**(-(I-1)/(N-1))
*>           MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND)
*>           MODE = 5 sets D to random numbers in the range
*>                    ( 1/COND , 1 ) such that their logarithms
*>                    are uniformly distributed.
*>           MODE = 6 set D to random numbers from same distribution
*>                    as the rest of the matrix.
*>           MODE < 0 has the same meaning as ABS(MODE), except that
*>              the order of the elements of D is reversed.
*>           Thus if MODE is between 1 and 4, D has entries ranging
*>              from 1 to 1/COND, if between -1 and -4, D has entries
*>              ranging from 1/COND to 1,
*>           Not modified.
*> \endverbatim
*>
*> \param[in] COND
*> \verbatim
*>          COND is DOUBLE PRECISION
*>           On entry, this is used as described under MODE above.
*>           If used, it must be >= 1. Not modified.
*> \endverbatim
*>
*> \param[in] DMAX
*> \verbatim
*>          DMAX is COMPLEX*16
*>           If MODE is neither -6, 0 nor 6, the contents of D, as
*>           computed according to MODE and COND, will be scaled by
*>           DMAX / max(abs(D(i))).  Note that DMAX need not be
*>           positive or real: if DMAX is negative or complex (or zero),
*>           D will be scaled by a negative or complex number (or zero).
*>           If RSIGN='F' then the largest (absolute) eigenvalue will be
*>           equal to DMAX.
*>           Not modified.
*> \endverbatim
*>
*> \param[in] RSIGN
*> \verbatim
*>          RSIGN is CHARACTER*1
*>           If MODE is not 0, 6, or -6, and RSIGN='T', then the
*>           elements of D, as computed according to MODE and COND, will
*>           be multiplied by a random complex number from the unit
*>           circle |z| = 1.  If RSIGN='F', they will not be.  RSIGN may
*>           only have the values 'T' or 'F'.
*>           Not modified.
*> \endverbatim
*>
*> \param[in] UPPER
*> \verbatim
*>          UPPER is CHARACTER*1
*>           If UPPER='T', then the elements of A above the diagonal
*>           will be set to random numbers out of DIST.  If UPPER='F',
*>           they will not.  UPPER may only have the values 'T' or 'F'.
*>           Not modified.
*> \endverbatim
*>
*> \param[in] SIM
*> \verbatim
*>          SIM is CHARACTER*1
*>           If SIM='T', then A will be operated on by a "similarity
*>           transform", i.e., multiplied on the left by a matrix X and
*>           on the right by X inverse.  X = U S V, where U and V are
*>           random unitary matrices and S is a (diagonal) matrix of
*>           singular values specified by DS, MODES, and CONDS.  If
*>           SIM='F', then A will not be transformed.
*>           Not modified.
*> \endverbatim
*>
*> \param[in,out] DS
*> \verbatim
*>          DS is DOUBLE PRECISION array, dimension ( N )
*>           This array is used to specify the singular values of X,
*>           in the same way that D specifies the eigenvalues of A.
*>           If MODE=0, the DS contains the singular values, which
*>           may not be zero.
*>           Modified if MODE is nonzero.
*> \endverbatim
*>
*> \param[in] MODES
*> \verbatim
*>          MODES is INTEGER
*> \endverbatim
*>
*> \param[in] CONDS
*> \verbatim
*>          CONDS is DOUBLE PRECISION
*>           Similar to MODE and COND, but for specifying the diagonal
*>           of S.  MODES=-6 and +6 are not allowed (since they would
*>           result in randomly ill-conditioned eigenvalues.)
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*>          KL is INTEGER
*>           This specifies the lower bandwidth of the  matrix.  KL=1
*>           specifies upper Hessenberg form.  If KL is at least N-1,
*>           then A will have full lower bandwidth.
*>           Not modified.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*>          KU is INTEGER
*>           This specifies the upper bandwidth of the  matrix.  KU=1
*>           specifies lower Hessenberg form.  If KU is at least N-1,
*>           then A will have full upper bandwidth; if KU and KL
*>           are both at least N-1, then A will be dense.  Only one of
*>           KU and KL may be less than N-1.
*>           Not modified.
*> \endverbatim
*>
*> \param[in] ANORM
*> \verbatim
*>          ANORM is DOUBLE PRECISION
*>           If ANORM is not negative, then A will be scaled by a non-
*>           negative real number to make the maximum-element-norm of A
*>           to be ANORM.
*>           Not modified.
*> \endverbatim
*>
*> \param[out] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension ( LDA, N )
*>           On exit A is the desired test matrix.
*>           Modified.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>           LDA specifies the first dimension of A as declared in the
*>           calling program.  LDA must be at least M.
*>           Not modified.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX*16 array, dimension ( 3*N )
*>           Workspace.
*>           Modified.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>           Error code.  On exit, INFO will be set to one of the
*>           following values:
*>             0 => normal return
*>            -1 => N negative
*>            -2 => DIST illegal string
*>            -5 => MODE not in range -6 to 6
*>            -6 => COND less than 1.0, and MODE neither -6, 0 nor 6
*>            -9 => RSIGN is not 'T' or 'F'
*>           -10 => UPPER is not 'T' or 'F'
*>           -11 => SIM   is not 'T' or 'F'
*>           -12 => MODES=0 and DS has a zero singular value.
*>           -13 => MODES is not in the range -5 to 5.
*>           -14 => MODES is nonzero and CONDS is less than 1.
*>           -15 => KL is less than 1.
*>           -16 => KU is less than 1, or KL and KU are both less than
*>                  N-1.
*>           -19 => LDA is less than M.
*>            1  => Error return from ZLATM1 (computing D)
*>            2  => Cannot scale to DMAX (max. eigenvalue is 0)
*>            3  => Error return from DLATM1 (computing DS)
*>            4  => Error return from ZLARGE
*>            5  => Zero singular value from DLATM1.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup complex16_matgen
*
*  =====================================================================
      SUBROUTINE ZLATME( N, DIST, ISEED, D, MODE, COND, DMAX,
     $  RSIGN,
     $                   UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM,
     $  A,
     $                   LDA, WORK, INFO )
*
*  -- LAPACK computational routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      CHARACTER          DIST, RSIGN, SIM, UPPER
      INTEGER            INFO, KL, KU, LDA, MODE, MODES, N
      DOUBLE PRECISION   ANORM, COND, CONDS
      COMPLEX*16         DMAX
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 )
      DOUBLE PRECISION   DS( * )
      COMPLEX*16         A( LDA, * ), D( * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
      COMPLEX*16         CZERO
      PARAMETER          ( CZERO = ( 0.0D+0, 0.0D+0 ) )
      COMPLEX*16         CONE
      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            BADS
      INTEGER            I, IC, ICOLS, IDIST, IINFO, IR, IROWS, IRSIGN,
     $                   ISIM, IUPPER, J, JC, JCR
      DOUBLE PRECISION   RALPHA, TEMP
      COMPLEX*16         ALPHA, TAU, XNORMS
*     ..
*     .. Local Arrays ..
      DOUBLE PRECISION   TEMPA( 1 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   ZLANGE
      COMPLEX*16         ZLARND
      EXTERNAL           LSAME, ZLANGE, ZLARND
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLATM1, XERBLA, ZCOPY, ZDSCAL, ZGEMV, ZGERC,
     $                   ZLACGV, ZLARFG, ZLARGE, ZLARNV, ZLASET, ZLATM1,
     $                   ZSCAL
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DCONJG, MAX, MOD
*     ..
*     .. Executable Statements ..
*
*     1)      Decode and Test the input parameters.
*             Initialize flags & seed.
*
      INFO = 0
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Decode DIST
*
      IF( LSAME( DIST, 'U' ) ) THEN
         IDIST = 1
      ELSE IF( LSAME( DIST, 'S' ) ) THEN
         IDIST = 2
      ELSE IF( LSAME( DIST, 'N' ) ) THEN
         IDIST = 3
      ELSE IF( LSAME( DIST, 'D' ) ) THEN
         IDIST = 4
      ELSE
         IDIST = -1
      END IF
*
*     Decode RSIGN
*
      IF( LSAME( RSIGN, 'T' ) ) THEN
         IRSIGN = 1
      ELSE IF( LSAME( RSIGN, 'F' ) ) THEN
         IRSIGN = 0
      ELSE
         IRSIGN = -1
      END IF
*
*     Decode UPPER
*
      IF( LSAME( UPPER, 'T' ) ) THEN
         IUPPER = 1
      ELSE IF( LSAME( UPPER, 'F' ) ) THEN
         IUPPER = 0
      ELSE
         IUPPER = -1
      END IF
*
*     Decode SIM
*
      IF( LSAME( SIM, 'T' ) ) THEN
         ISIM = 1
      ELSE IF( LSAME( SIM, 'F' ) ) THEN
         ISIM = 0
      ELSE
         ISIM = -1
      END IF
*
*     Check DS, if MODES=0 and ISIM=1
*
      BADS = .FALSE.
      IF( MODES.EQ.0 .AND. ISIM.EQ.1 ) THEN
         DO 10 J = 1, N
            IF( DS( J ).EQ.ZERO )
     $         BADS = .TRUE.
   10    CONTINUE
      END IF
*
*     Set INFO if an error
*
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( IDIST.EQ.-1 ) THEN
         INFO = -2
      ELSE IF( ABS( MODE ).GT.6 ) THEN
         INFO = -5
      ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE )
     $          THEN
         INFO = -6
      ELSE IF( IRSIGN.EQ.-1 ) THEN
         INFO = -9
      ELSE IF( IUPPER.EQ.-1 ) THEN
         INFO = -10
      ELSE IF( ISIM.EQ.-1 ) THEN
         INFO = -11
      ELSE IF( BADS ) THEN
         INFO = -12
      ELSE IF( ISIM.EQ.1 .AND. ABS( MODES ).GT.5 ) THEN
         INFO = -13
      ELSE IF( ISIM.EQ.1 .AND. MODES.NE.0 .AND. CONDS.LT.ONE ) THEN
         INFO = -14
      ELSE IF( KL.LT.1 ) THEN
         INFO = -15
      ELSE IF( KU.LT.1 .OR. ( KU.LT.N-1 .AND. KL.LT.N-1 ) ) THEN
         INFO = -16
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -19
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZLATME', -INFO )
         RETURN
      END IF
*
*     Initialize random number generator
*
      DO 20 I = 1, 4
         ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 )
   20 CONTINUE
*
      IF( MOD( ISEED( 4 ), 2 ).NE.1 )
     $   ISEED( 4 ) = ISEED( 4 ) + 1
*
*     2)      Set up diagonal of A
*
*             Compute D according to COND and MODE
*
      CALL ZLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, IINFO )
      IF( IINFO.NE.0 ) THEN
         INFO = 1
         RETURN
      END IF
      IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN
*
*        Scale by DMAX
*
         TEMP = ABS( D( 1 ) )
         DO 30 I = 2, N
            TEMP = MAX( TEMP, ABS( D( I ) ) )
   30    CONTINUE
*
         IF( TEMP.GT.ZERO ) THEN
            ALPHA = DMAX / TEMP
         ELSE
            INFO = 2
            RETURN
         END IF
*
         CALL ZSCAL( N, ALPHA, D, 1 )
*
      END IF
*
      CALL ZLASET( 'Full', N, N, CZERO, CZERO, A, LDA )
      CALL ZCOPY( N, D, 1, A, LDA+1 )
*
*     3)      If UPPER='T', set upper triangle of A to random numbers.
*
      IF( IUPPER.NE.0 ) THEN
         DO 40 JC = 2, N
            CALL ZLARNV( IDIST, ISEED, JC-1, A( 1, JC ) )
   40    CONTINUE
      END IF
*
*     4)      If SIM='T', apply similarity transformation.
*
*                                -1
*             Transform is  X A X  , where X = U S V, thus
*
*             it is  U S V A V' (1/S) U'
*
      IF( ISIM.NE.0 ) THEN
*
*        Compute S (singular values of the eigenvector matrix)
*        according to CONDS and MODES
*
         CALL DLATM1( MODES, CONDS, 0, 0, ISEED, DS, N, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = 3
            RETURN
         END IF
*
*        Multiply by V and V'
*
         CALL ZLARGE( N, A, LDA, ISEED, WORK, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = 4
            RETURN
         END IF
*
*        Multiply by S and (1/S)
*
         DO 50 J = 1, N
            CALL ZDSCAL( N, DS( J ), A( J, 1 ), LDA )
            IF( DS( J ).NE.ZERO ) THEN
               CALL ZDSCAL( N, ONE / DS( J ), A( 1, J ), 1 )
            ELSE
               INFO = 5
               RETURN
            END IF
   50    CONTINUE
*
*        Multiply by U and U'
*
         CALL ZLARGE( N, A, LDA, ISEED, WORK, IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = 4
            RETURN
         END IF
      END IF
*
*     5)      Reduce the bandwidth.
*
      IF( KL.LT.N-1 ) THEN
*
*        Reduce bandwidth -- kill column
*
         DO 60 JCR = KL + 1, N - 1
            IC = JCR - KL
            IROWS = N + 1 - JCR
            ICOLS = N + KL - JCR
*
            CALL ZCOPY( IROWS, A( JCR, IC ), 1, WORK, 1 )
            XNORMS = WORK( 1 )
            CALL ZLARFG( IROWS, XNORMS, WORK( 2 ), 1, TAU )
            TAU = DCONJG( TAU )
            WORK( 1 ) = CONE
            ALPHA = ZLARND( 5, ISEED )
*
            CALL ZGEMV( 'C', IROWS, ICOLS, CONE, A( JCR, IC+1 ), LDA,
     $                  WORK, 1, CZERO, WORK( IROWS+1 ), 1 )
            CALL ZGERC( IROWS, ICOLS, -TAU, WORK, 1, WORK( IROWS+1 ), 1,
     $                  A( JCR, IC+1 ), LDA )
*
            CALL ZGEMV( 'N', N, IROWS, CONE, A( 1, JCR ), LDA, WORK, 1,
     $                  CZERO, WORK( IROWS+1 ), 1 )
            CALL ZGERC( N, IROWS, -DCONJG( TAU ), WORK( IROWS+1 ), 1,
     $                  WORK, 1, A( 1, JCR ), LDA )
*
            A( JCR, IC ) = XNORMS
            CALL ZLASET( 'Full', IROWS-1, 1, CZERO, CZERO,
     $                   A( JCR+1, IC ), LDA )
*
            CALL ZSCAL( ICOLS+1, ALPHA, A( JCR, IC ), LDA )
            CALL ZSCAL( N, DCONJG( ALPHA ), A( 1, JCR ), 1 )
   60    CONTINUE
      ELSE IF( KU.LT.N-1 ) THEN
*
*        Reduce upper bandwidth -- kill a row at a time.
*
         DO 70 JCR = KU + 1, N - 1
            IR = JCR - KU
            IROWS = N + KU - JCR
            ICOLS = N + 1 - JCR
*
            CALL ZCOPY( ICOLS, A( IR, JCR ), LDA, WORK, 1 )
            XNORMS = WORK( 1 )
            CALL ZLARFG( ICOLS, XNORMS, WORK( 2 ), 1, TAU )
            TAU = DCONJG( TAU )
            WORK( 1 ) = CONE
            CALL ZLACGV( ICOLS-1, WORK( 2 ), 1 )
            ALPHA = ZLARND( 5, ISEED )
*
            CALL ZGEMV( 'N', IROWS, ICOLS, CONE, A( IR+1, JCR ), LDA,
     $                  WORK, 1, CZERO, WORK( ICOLS+1 ), 1 )
            CALL ZGERC( IROWS, ICOLS, -TAU, WORK( ICOLS+1 ), 1, WORK, 1,
     $                  A( IR+1, JCR ), LDA )
*
            CALL ZGEMV( 'C', ICOLS, N, CONE, A( JCR, 1 ), LDA, WORK, 1,
     $                  CZERO, WORK( ICOLS+1 ), 1 )
            CALL ZGERC( ICOLS, N, -DCONJG( TAU ), WORK, 1,
     $                  WORK( ICOLS+1 ), 1, A( JCR, 1 ), LDA )
*
            A( IR, JCR ) = XNORMS
            CALL ZLASET( 'Full', 1, ICOLS-1, CZERO, CZERO,
     $                   A( IR, JCR+1 ), LDA )
*
            CALL ZSCAL( IROWS+1, ALPHA, A( IR, JCR ), 1 )
            CALL ZSCAL( N, DCONJG( ALPHA ), A( JCR, 1 ), LDA )
   70    CONTINUE
      END IF
*
*     Scale the matrix to have norm ANORM
*
      IF( ANORM.GE.ZERO ) THEN
         TEMP = ZLANGE( 'M', N, N, A, LDA, TEMPA )
         IF( TEMP.GT.ZERO ) THEN
            RALPHA = ANORM / TEMP
            DO 80 J = 1, N
               CALL ZDSCAL( N, RALPHA, A( 1, J ), 1 )
   80       CONTINUE
         END IF
      END IF
*
      RETURN
*
*     End of ZLATME
*
      END


!*==zgetrf.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b ZGETRF
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZGETRF + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            INFO, LDA, M, N
!       ..
!       .. Array Arguments ..
!       INTEGER            IPIV( * )
!       COMPLEX*16         A( LDA, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZGETRF computes an LU factorization of a general M-by-N matrix A
!> using partial pivoting with row interchanges.
!>
!> The factorization has the form
!>    A = P * L * U
!> where P is a permutation matrix, L is lower triangular with unit
!> diagonal elements (lower trapezoidal if m > n), and U is upper
!> triangular (upper trapezoidal if m < n).
!>
!> This is the right-looking Level 3 BLAS version of the algorithm.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the M-by-N matrix to be factored.
!>          On exit, the factors L and U from the factorization
!>          A = P*L*U; the unit diagonal elements of L are not stored.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!> \endverbatim
!>
!> \param[out] IPIV
!> \verbatim
!>          IPIV is INTEGER array, dimension (min(M,N))
!>          The pivot indices; for 1 <= i <= min(M,N), row i of the
!>          matrix was interchanged with row IPIV(i).
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
!>                has been completed, but the factor U is exactly
!>                singular, and division by zero will occur if it is used
!>                to solve a system of equations.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complex16GEcomputational
!
!  =====================================================================
      SUBROUTINE ZGETRF(M,N,A,Lda,Ipiv,Info)
      IMPLICIT NONE
!*--ZGETRF112
!
!  -- 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 ..
      INTEGER Info , Lda , M , N
!     ..
!     .. Array Arguments ..
      INTEGER Ipiv(*)
      COMPLEX*16 A(Lda,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX*16 ONE
      PARAMETER (ONE=(1.0D+0,0.0D+0))
!     ..
!     .. Local Scalars ..
      INTEGER i , iinfo , j , jb , nb
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA , ZGEMM , ZGETRF2 , ZLASWP , ZTRSM
!     ..
!     .. External Functions ..
      INTEGER ILAENV
      EXTERNAL ILAENV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      Info = 0
      IF ( M<0 ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -4
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('ZGETRF',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( M==0 .OR. N==0 ) RETURN
!
!     Determine the block size for this environment.
!
      nb = ILAENV(1,'ZGETRF',' ',M,N,-1,-1)
      IF ( nb<=1 .OR. nb>=MIN(M,N) ) THEN
!
!        Use unblocked code.
!
         CALL ZGETRF2(M,N,A,Lda,Ipiv,Info)
      ELSE
!
!        Use blocked code.
!
         DO j = 1 , MIN(M,N) , nb
            jb = MIN(MIN(M,N)-j+1,nb)
!
!           Factor diagonal and subdiagonal blocks and test for exact
!           singularity.
!
            CALL ZGETRF2(M-j+1,jb,A(j,j),Lda,Ipiv(j),iinfo)
!
!           Adjust INFO and the pivot indices.
!
            IF ( Info==0 .AND. iinfo>0 ) Info = iinfo + j - 1
            DO i = j , MIN(M,j+jb-1)
               Ipiv(i) = j - 1 + Ipiv(i)
            ENDDO
!
!           Apply interchanges to columns 1:J-1.
!
            CALL ZLASWP(j-1,A,Lda,j,j+jb-1,Ipiv,1)
!
            IF ( j+jb<=N ) THEN
!
!              Apply interchanges to columns J+JB:N.
!
               CALL ZLASWP(N-j-jb+1,A(1,j+jb),Lda,j,j+jb-1,Ipiv,1)
!
!              Compute block row of U.
!
               CALL ZTRSM('Left','Lower','No transpose','Unit',jb,      &
     &                    N-j-jb+1,ONE,A(j,j),Lda,A(j,j+jb),Lda)
!
!                 Update trailing submatrix.
!
               IF ( j+jb<=M ) CALL ZGEMM('No transpose','No transpose', &
     &              M-j-jb+1,N-j-jb+1,jb,-ONE,A(j+jb,j),Lda,A(j,j+jb),  &
     &              Lda,ONE,A(j+jb,j+jb),Lda)
            ENDIF
         ENDDO
      ENDIF
!
!     End of ZGETRF
!
      END SUBROUTINE ZGETRF


C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE CSA3LXD(NI,XI,UI,WTS,KNOTS,SSMTH,NDERIV,NO,XO,YO,ZO,UO,
     +                   NWRK,WORK,IER)
      DOUBLE PRECISION XI
      DOUBLE PRECISION UI
      DOUBLE PRECISION WTS
      DOUBLE PRECISION SSMTH
      DOUBLE PRECISION XO
      DOUBLE PRECISION YO
      DOUBLE PRECISION ZO
      DOUBLE PRECISION UO
      DOUBLE PRECISION WORK
      DOUBLE PRECISION XMN
      DOUBLE PRECISION XMX
      DOUBLE PRECISION XV
      DOUBLE PRECISION SPLDED
C
C  Alternate entry where the output points are specified as a list.
C
      DIMENSION XI(3,NI),UI(NI),WTS(*),KNOTS(3),XO(NO),YO(NO),ZO(NO),
     +          UO(NO),WORK(NWRK)
      DIMENSION XMN(3),XMX(3),XV(3),NDERIV(3)
C
C  Check on the number of knots.
C
      NTOT = KNOTS(1)*KNOTS(2)*KNOTS(3)
C
      DO 20 I = 1,3
          IF (KNOTS(I).LT.4) THEN
              CALL CFAERR(202,
     +' CSA3LXD - must have at least four knots in every coordinate dire
     +ction',70)
              IER = 202
              RETURN
          END IF
   20 CONTINUE
C
C  Check on the size of the workspace.
C
      IF (NWRK.LT.NTOT* (NTOT+3)) THEN
          CALL CFAERR(203,' CSA3LXD - workspace too small',30)
          IER = 203
          RETURN
      END IF
C
C  Calculate the min and max for the knots as the minimum value of
C  the input data and output data and the maximum of the input and
C  output data.
C
      DO 30 J = 1,3
          XMN(J) = XI(J,1)
          XMX(J) = XI(J,1)
          DO 10 I = 2,NI
              XMN(J) = MIN(XMN(J),XI(J,I))
              XMX(J) = MAX(XMX(J),XI(J,I))
   10     CONTINUE
   30 CONTINUE
C
      DO 70 I = 1,NO
          XMN(1) = MIN(XMN(1),XO(I))
          XMN(2) = MIN(XMN(2),YO(I))
          XMN(3) = MIN(XMN(3),ZO(I))
          XMX(1) = MAX(XMX(1),XO(I))
          XMX(2) = MAX(XMX(2),YO(I))
          XMX(3) = MAX(XMX(3),ZO(I))
   70 CONTINUE
C
C  Find the coefficients.
C
      CALL SPLCWD(3,XI,3,UI,WTS,NI,XMN,XMX,KNOTS,SSMTH,WORK,NTOT,
     +            WORK(NTOT+1),NWRK-NTOT,IERR)
      IF (IERR.NE.0) RETURN
C
C  Calculate the approximated values (coefficients are stored at
C  the beginnig of WORK).
C
      DO 60 I = 1,NO
          XV(1) = XO(I)
          XV(2) = YO(I)
          XV(3) = ZO(I)
          UO(I) = SPLDED(3,XV,NDERIV,WORK,XMN,XMX,KNOTS,IER)
          IF (IERR.NE.0) RETURN
   60 CONTINUE
C
      RETURN
      END


!##############################################################################
!# ****************************************************************************
!# <name> poissoncallback </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module contains callback functions for the poisson problem that are
!# used during the matrix/vector assembly for specifying analytical data.
!# There are three callback functions involved, which may be called depending
!# on the situation. All of them correspond to a specific interface for
!# callback functions, defined in 'intf_xxxx.inc' files.
!#
!# 1.) coeff_Laplace
!#     -> Returns the coefficients for the Laplace matrix. This routine is
!#        only used if the problem to calculate has nonconstant coefficients!
!#        Otherwise the routine is dead.
!#     -> Corresponds to the interface defined in the file
!#        'intf_coefficientMatrixSc.inc'
!#
!# 2.) coeff_RHS_phi
!#     -> Returns analytical values for the right hand side of the Laplace
!#        equation.
!#     -> Corresponds to the interface defined in the file
!#        'intf_coefficientVectorSc.inc'
!#
!# 2') coeff_RHS_w
!#
!# 3.) getBoundaryValues
!#     -> Returns analitical values on the (Dirichlet) boundary of the
!#        problem to solve.
!#     -> Corresponds to the interface defined in the file
!#        'intf_bcassembly.inc'
!#
!# 4.) CH_iniconPhi
!# 5.) CH_iniconChemP
!#
!# 6.) coeff_NonlinearMass
!# 7.) coeff_VarMass
!# 8.) coeff_VarLaplace
!#
!#
!# </purpose>
!##############################################################################

module CahnHilliard_callback

  use fsystem
  use storage
  use linearsolver
  use boundary
  use bilinearformevaluation
  use linearformevaluation
  use cubature
  use matrixfilters
  use vectorfilters
  use bcassembly
  use mprimitives
  use derivatives

  use feevaluation

  use CahnHilliard_basic
  use ccbasic

  IMPLICIT NONE

CONTAINS

! ***************************************************************************
  !<subroutine>
  subroutine CH_iniconPhi(x, y, f_val)

!<description>
  ! Give you the initial soluiont of Cahn-Hilliard equation, for c
!</description>

!<inputoutput>
  real(DP), intent(in) :: x, y
  real(DP), intent(out) :: f_val
!</inputoutput>

!</subroutine>

 ! local variables
  real(DP) :: delta

!    delta=(x-0.5_DP)**2+(y-0.5_DP)**2+1.0_DP
!    f_val=delta

    delta=(x-0.5_DP)**2/0.01_DP+(y-0.5_DP)**2/0.0225_DP-1.0_DP
	f_val=tanh(delta)

!     f_val=1.0_DP

!    if ((x .ge. 0.35) .and. (x .le. 0.65) .and. (y .ge. 0.35) .and. (y .le. 0.65)) then
!       f_val=1.0_DP
!    else
!       f_val=-1.0_DP
!    end if

!    delta=(x-0.5_DP)**2/0.01_DP+(y-0.5_DP)**2/0.0225_DP-1.0_DP
!    f_val=tanh(delta)

! if ((((x - 0.4)**2  + (y - 0.5)**2)  .le.  0.01_DP) .or.  &
!           (((x - 0.6)**2  + (y - 0.5)**2) .le.  0.01_DP)) then
!        f_val = 1.0_DP
!      else
!        f_val = -1.0_DP
!       end if

  end subroutine

! ***************************************************************************
  !<subroutine>
  subroutine CH_iniconChemP(x, y, f_val)

!<description>
  ! Give you the initial soluiont of Cahn-Hilliard equation, for w
!</description>

!<inputoutput>
  real(DP), intent(in) :: x, y
  real(DP), intent(out) :: f_val
!</inputoutput>

!</subroutine>

 ! local variables
  real(DP) :: delta, phi
  real(DP) :: eps=0.02_DP

!    delta=(x-0.5_DP)**2+(y-0.5_DP)**2+1.0_DP
!    f_val=delta

 ! The chemical potential is
  ! w = (phi^3 - phi)/eps - eps * Laplace \phi

!  f_val=(phi**3-phi)/ep-ep*(-80000*phi*(1-phi**2)*(x-0.5_DP)**2+&
!          2600/9-2600/9*phi**2-1280000/81*phi*(1-phi**2)*(y-0.5_DP)**2)
  ! The following one is based on matlab, the above one is based on Chain rule.
!Feng's setting
!  phi= tanh(100*(x-0.5_DP)**2+400.0_DP/9.0_DP*(y-0.5_DP)**2-1.0_DP)
!  f_val=2.0_DP*phi*(1.0_DP-phi**2)*(200.0_DP*x-100.0_DP)**2-2600.0_DP/9.0_DP+&
!    2600.0_DP/9.0_DP*phi**2+2.0_DP*phi*(1.0_DP-phi**2)*(800.0_DP/9.0_DP*y-400.0_DP/9.0_DP)**2+&
!	(phi**3-phi)/eps**2

 ! Kay's setting
   phi=tanh((x-0.5_DP)**2/0.01_DP+(y-0.5_DP)**2/0.0225_DP-1.0_DP)
   f_val=(phi**3-phi)/eps-eps*(-2.0_DP*phi*(1.0_DP-phi**2)*(200.0_DP*x-100.0_DP)**2+&
         2600.0_DP/9.0_DP-2600.0_DP/9.0_DP*phi**2-&
         2.0_DP*phi*(1-phi**2)*(800.0_DP/9.0_DP*y-400.0_DP/9.0_DP)**2)

!     f_val=1.0_DP

!    if ((x .ge. 0.35) .and. (x .le. 0.65) .and. (y .ge. 0.35) .and. (y .le. 0.65)) then
!       f_val=1.0_DP
!    else
!       f_val=-1.0_DP
!    end if

!    delta=(x-0.5_DP)**2/0.01_DP+(y-0.5_DP)**2/0.025_DP-1.0_DP
!    f_val=tanh(delta)

! if ((((x - 0.4)**2  + (y - 0.5)**2)  .le.  0.01_DP) .or.  &
!           (((x - 0.6)**2  + (y - 0.5)**2) .le.  0.01_DP)) then
!        f_val = 1.0_DP
!      else
!        f_val = -1.0_DP
!       end if

  end subroutine

!***************************************************************************
! MCai
!<subroutine>
  subroutine coeff_nonlinear (rdiscretisation,rform, &
                  nelements,npointsPerElement,Dpoints, &
                  IdofsTest,rdomainIntSubset,&
                  Dcoefficients,rcollection)

    use basicgeometry
    use triangulation
    use collection
    use scalarpde
    use domainintegration

  !<description>
    ! This subroutine is to calculate nonlinear term in assembling defect:
	! Specifically, it corresponds to (C^3-C, \psi), \psi is test function.
	! We use linearform to do this L^2 inner product. See also ACNS applications.
  !</description>

  !<input>
    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.
    type(t_spatialDiscretisation), intent(IN)                   :: rdiscretisation

    ! The linear form which is currently to be evaluated:
    type(t_linearForm), intent(IN)                              :: rform

    ! Number of elements, where the coefficients must be computed.
    integer, intent(IN)                                         :: nelements

    ! Number of points per element, where the coefficients must be computed
    integer, intent(IN)                                         :: npointsPerElement

    ! This is an array of all points on all the elements where coefficients
    ! are needed.
    ! Remark: This usually coincides with rdomainSubset%p_DcubPtsreal.
    ! DIMENSION(dimension,npointsPerElement,nelements)
    real(DP), DIMENSION(:,:,:), intent(IN)  :: Dpoints

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(#local DOF's in test space,nelements)
    INTEGER, DIMENSION(:,:), intent(IN) :: IdofsTest

    ! This is a t_domainIntSubset structure specifying more detailed information
    ! about the element set that is currently being integrated.
    ! It's usually used in more complex situations (e.g. nonlinear matrices).
    type(t_domainIntSubset), intent(IN)              :: rdomainIntSubset

    ! Optional: A collection structure to provide additional
    ! information to the coefficient routine.
    type(t_collection), intent(INOUT), OPTIONAL      :: rcollection

  !</input>

  !<output>
    ! A list of all coefficients in front of all terms in the linear form -
    ! for all given points on all given elements.
    !   DIMENSION(itermCount,npointsPerElement,nelements)
    ! with itermCount the number of terms in the linear form.

    real(DP), DIMENSION(:,:,:), intent(OUT)          :: Dcoefficients

    ! Values of the FE function at the points specified by Dpoints.
    ! DIMENSION(itermCount, npoints,nelements).
    real(DP), dimension(:,:,:), allocatable :: Dvalues

    integer :: i, j

	! rInnervector is to save rACvector from previous step
    type(t_vectorblock),pointer :: rInnervector
    real(DP) :: f_val

    !  rOutervector is to save rNSvector
!    type(t_vectorblock) :: rOutvector
  !</output>

!</subroutine>

! we treat the source term explicitly (f(\phi(t_n)), \psi)
  if (present(rcollection)) then

!Mcai, we need to modify something here   ! Refer to nonlinear_calcDefect
      rInnervector=>rcollection%p_rvectorQuickAccess2

      allocate(Dvalues(1,npointsPerElement,nelements))

! We need rInnervector
      call fevl_evaluate_sim4 (rInnervector%RvectorBlock(1), &
	                         rdomainIntSubset, DER_FUNC, Dvalues, 1)

! Dcoefficients only have 1 itemcount
      do i = 1,nelements
         do j = 1, npointsPerElement
! Debug, check Dvalues are correct
!              print *, Dvalues(1, j, i)
	       call cubicfun_val(Dvalues(1,j,i), f_val)
! Dcoefficients only have 1 item
           Dcoefficients(1,j,i)=f_val
         end do
      end do

      deallocate(Dvalues)
  end if

  end subroutine

  subroutine cubicfun_val(phi, f_val)
  real(DP), intent(IN) :: phi
  real(DP), intent(INOUT) :: f_val

     f_val=(phi**2-1.0_DP)*phi
  end subroutine

! ***************************************************************************

  !<subroutine>
  subroutine coeff_NonlinearPrec (rdiscretisationTrial,rdiscretisationTest,rform, &
                  nelements,npointsPerElement,Dpoints, &
                  IdofsTrial,IdofsTest,rdomainIntSubset, &
                  Dcoefficients,rcollection)

    use basicgeometry
    use triangulation
    use collection
    use scalarpde
    use domainintegration

  !<description>
    ! This subroutine is called during the matrix assembly: CH_assemblyMatrix.
	! It is used to construct preconditioner for nonlinear system, see
	! CH_generateNonlinearMat
    !
  !</description>

  !<input>
    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.; trial space.
    type(t_spatialDiscretisation), intent(IN)                   :: rdiscretisationTrial

    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.; test space.
    type(t_spatialDiscretisation), intent(IN)                   :: rdiscretisationTest

    ! The bilinear form which is currently being evaluated:
    type(t_bilinearForm), intent(IN)                            :: rform

    ! Number of elements, where the coefficients must be computed.
    integer, intent(IN)                        :: nelements

    ! Number of points per element, where the coefficients must be computed
    integer, intent(IN)                                         :: npointsPerElement

    ! This is an array of all points on all the elements where coefficients
    ! are needed.
    ! Remark: This usually coincides with rdomainSubset%p_DcubPtsreal.
    ! DIMENSION(dimension,npointsPerElement,nelements)
    real(DP), dimension(:,:,:), intent(IN)  :: Dpoints

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(#local DOF's in trial space,nelements)
    integer, dimension(:,:), intent(IN) :: IdofsTrial

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(#local DOF's in test space,nelements)
    integer, dimension(:,:), intent(IN) :: IdofsTest

    ! This is a t_domainIntSubset structure specifying more detailed information
    ! about the element set that is currently being integrated.
    ! It's usually used in more complex situations (e.g. nonlinear matrices).
    type(t_domainIntSubset), intent(IN)              :: rdomainIntSubset

    ! Optional: A collection structure to provide additional
    ! information to the coefficient routine.
    type(t_collection), intent(INOUT), optional      :: rcollection

  !</input>

  !<output>
    ! A list of all coefficients in front of all terms in the bilinear form -
    ! for all given points on all given elements.
    !   DIMENSION(itermCount,npointsPerElement,nelements)
    ! with itermCount the number of terms in the bilinear form.
    real(DP), dimension(:,:,:), intent(OUT)                      :: Dcoefficients
  !</output>

  !</subroutine>
    ! local variables
    ! Values of the FE function at the points specified by Dpoints.
    ! DIMENSION(itermCount, npoints, nelements).
    real(DP), dimension(:,:,:), allocatable :: Dvalues

    integer :: i, j

	! rInnervector is to save rvector from previous step
    type(t_vectorblock),pointer :: rInnervector
    real(DP) :: f_val
	real(DP) :: eps=0.02_DP
  !</output>

  !</subroutine>

!  Dcoefficients = 0.0_DP

! we treat the source term explicitly (f(\phi(t_n)), \psi)
    if (present(rcollection)) then

!Mcai, we need to modify something here
      rInnervector=>rcollection%p_rvectorQuickAccess1
      allocate(Dvalues(1,npointsPerElement,nelements))

! We need function values at quad points
      call fevl_evaluate_sim4 (rInnervector%RvectorBlock(1), &
	                         rdomainIntSubset, DER_FUNC, Dvalues, 1)

! Dcoefficients only have 1 itemcount
      do i = 1,nelements
        do j = 1, npointsPerElement
! Debug, check Dvalues are correct
!           print *, Dvalues(1, j, i)
	      call Cubicderivative_fun(Dvalues(1,j,i), f_val)
! Dcoefficients only have 1 item: our formulation is based on Kay's paper
          Dcoefficients(1,j,i)=f_val/eps
        end do
      end do

      deallocate(Dvalues)
    end if

  end subroutine

  subroutine Cubicderivative_fun(c, f_val)
  real(DP), intent(IN) :: c
  ! f_val is the mobility
  real(DP), intent(INOUT) :: f_val
  ! local variable
  ! We should use derivative, Newton like nonlinear solver: Jacobian.
     f_val=3.0_DP*c**2-1.0_DP

  end subroutine

!**********************************************************************************
 subroutine coeff_Conv (rdiscretisationTrial,rdiscretisationTest,rform, &
                  nelements,npointsPerElement,Dpoints, &
                  IdofsTrial,IdofsTest,rdomainIntSubset, &
                  Dcoefficients,rcollection)

    use basicgeometry
    use triangulation
    use collection
    use scalarpde
    use domainintegration

  !<description>
    ! This subroutine is called during the matrix assembly. It has to compute
    ! the coefficients in front of the terms of the bilinear form.
    !
    ! In this example, we compute the poisson example with a nonconstant
    ! coefficient depending on a finite element function. The FE function is
    ! passed to this routine via the collection structure rcollection.
  !</description>

  !<input>
    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.; trial space.
    type(t_spatialDiscretisation), intent(IN)                   :: rdiscretisationTrial

    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.; test space.
    type(t_spatialDiscretisation), intent(IN)                   :: rdiscretisationTest

    ! The bilinear form which is currently being evaluated:
    type(t_bilinearForm), intent(IN)                            :: rform

    ! Number of elements, where the coefficients must be computed.
    integer, intent(IN)                        :: nelements

    ! Number of points per element, where the coefficients must be computed
    integer, intent(IN)                                         :: npointsPerElement

    ! This is an array of all points on all the elements where coefficients
    ! are needed.
    ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
    ! DIMENSION(dimension,npointsPerElement,nelements)
    real(DP), dimension(:,:,:), intent(IN)  :: Dpoints

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(#local DOF's in trial space,nelements)
    integer, dimension(:,:), intent(IN) :: IdofsTrial

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(#local DOF's in test space,nelements)
    integer, dimension(:,:), intent(IN) :: IdofsTest

    ! This is a t_domainIntSubset structure specifying more detailed information
    ! about the element set that is currently being integrated.
    ! It's usually used in more complex situations (e.g. nonlinear matrices).
    type(t_domainIntSubset), intent(IN)              :: rdomainIntSubset

    ! Optional: A collection structure to provide additional
    ! information to the coefficient routine.
    type(t_collection), intent(INOUT), optional      :: rcollection

  !</input>

  !<output>
    ! A list of all coefficients in front of all terms in the bilinear form -
    ! for all given points on all given elements.
    !   DIMENSION(itermCount,npointsPerElement,nelements)
    ! with itermCount the number of terms in the bilinear form.
    real(DP), dimension(:,:,:), intent(OUT)          :: Dcoefficients
  !</output>
  !</subroutine>
    ! local variables
    ! Values of the FE function at the points specified by Dpoints.
    ! DIMENSION(itermCount, npoints, nelements).
    real(DP), dimension(:,:,:), allocatable :: Dvalues_X, Dvalues_Y

    integer :: i, j

	! rInnervector is to save rvector from previous step
    type(t_vectorblock),pointer :: rOutervector

  !</output>

  !</subroutine>

!  Dcoefficients = 0.0_DP

    if (present(rcollection)) then
!Mcai, p_rvectorQuickAccess2 is for rNSvector
      rOutervector=>rcollection%p_rvectorQuickAccess1

      allocate(Dvalues_X(1,npointsPerElement,nelements))
      allocate(Dvalues_Y(1,npointsPerElement,nelements))

! We need function values at quad points: RvectorBlock(1) for 1st component of vel
      call fevl_evaluate_sim4 (rOutervector%RvectorBlock(1), &
	                         rdomainIntSubset, DER_FUNC, Dvalues_X, 1)
      call fevl_evaluate_sim4 (rOutervector%RvectorBlock(2), &
	                         rdomainIntSubset, DER_FUNC, Dvalues_Y, 1)

! Dcoefficients only have 1 itemcount
      do i = 1,nelements
        do j = 1, npointsPerElement
          ! MCai: {\bf u} \cdot \grad \phi
          ! Dcoefficients have 2 items?
          Dcoefficients(1,j,i)=Dvalues_X(1,j,i)
    	  Dcoefficients(2,j,i)=Dvalues_Y(1,j,i)
        end do
      end do

      deallocate(Dvalues_X)
      deallocate(Dvalues_Y)
    end if

  end subroutine

! ***************************************************************
   subroutine Coeff_conv1 (rdiscretisationTest,rdiscretisationTrial,rform, &
                  nelements,npointsPerElement,Dpoints, &
                  IdofsTrial,IdofsTest,rdomainIntSubset,&
                  Dcoefficients, rcollection)

    use basicgeometry
    use triangulation
    use collection
    use scalarpde
    use domainintegration

  !<description>
    ! This subroutine is called during the matrix assembly. It has to compute
    ! the coefficients in front of the terms of the bilinear form.
    !
    ! The routine accepts a set of elements and a set of points on these
    ! elements (cubature points) in real coordinates.
    ! According to the terms in the bilinear form, the routine has to compute
    ! simultaneously for all these points and all the terms in the bilinear form
    ! the corresponding coefficients in front of the terms.
  !</description>

  !<input>
    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.; test space.
    type(t_spatialDiscretisation), intent(IN)                   :: rdiscretisationTest

    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.; trial space.
    type(t_spatialDiscretisation), intent(IN)                   :: rdiscretisationTrial

    ! The trilinear form which is currently being evaluated:
    type(t_trilinearForm), intent(IN)                            :: rform

    ! Number of elements, where the coefficients must be computed.
    integer(PREC_ELEMENTIDX), intent(IN)                        :: nelements

    ! Number of points per element, where the coefficients must be computed
    integer, intent(IN)                                         :: npointsPerElement

    ! This is an array of all points on all the elements where coefficients
    ! are needed.
    ! DIMENSION(dimension,npointsPerElement,nelements)
    real(DP), dimension(:,:,:), intent(IN)  :: Dpoints

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(\#local DOF's in trial space,Number of elements)
    integer, dimension(:,:), intent(IN) :: IdofsTrial

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(\#local DOF's in test space,Number of elements)
    integer, dimension(:,:), intent(IN) :: IdofsTest

    ! This is a t_domainIntSubset structure specifying more detailed information
    ! about the element set that is currently being integrated.
    ! It's usually used in more complex situations (e.g. nonlinear matrices).
    type(t_domainIntSubset), intent(IN)              :: rdomainIntSubset

    ! Optional: A collection structure to provide additional
    ! information to the coefficient routine.
    type(t_collection), intent(INOUT), optional ,target     :: rcollection

  !</input>

  !<output>
    ! A list of all coefficients in front of all terms in the bilinear form -
    ! for all given points on all given elements.
    !   DIMENSION(itermCount,npointsPerElement,nelements)
    ! with itermCount the number of terms in the bilinear form.
    real(DP), dimension(:,:,:), intent(OUT)                      :: Dcoefficients
  !</output>

  !</subroutine>
    ! local variables
    ! Values of the FE function at the points specified by Dpoints.
    ! DIMENSION(itermCount, npoints, nelements).
    real(DP), dimension(:,:,:), allocatable :: Dvalues_X

    integer :: i, j

	! rInnervector is to save rvector from previous step
    type(t_vectorblock),pointer :: rOutervector

  !</output>

  !</subroutine>

!  Dcoefficients = 0.0_DP

    if (present(rcollection)) then
!Mcai, p_rvectorQuickAccess2 is for rNSvector
      rOutervector=>rcollection%p_rvectorQuickAccess2

      allocate(Dvalues_X(1,npointsPerElement,nelements))

! We need function values at quad points: RvectorBlock(1) for 1st component of vel
      call fevl_evaluate_sim4 (rOutervector%RvectorBlock(1), &
	                         rdomainIntSubset, DER_FUNC, Dvalues_X, 1)

! Dcoefficients only have 1 itemcount
      do i = 1,nelements
        do j = 1, npointsPerElement
          ! MCai: {\bf u} \cdot \grad \phi
          ! Dcoefficients have 2 items?
          Dcoefficients(1,j,i)=Dvalues_X(1,j,i)
        end do
      end do

      deallocate(Dvalues_X)
    end if

  end subroutine

! ***************************************************************
   subroutine Coeff_conv2 (rdiscretisationTest,rdiscretisationTrial,rform, &
                  nelements,npointsPerElement,Dpoints, &
                  IdofsTrial,IdofsTest,rdomainIntSubset,&
                  Dcoefficients, rcollection)

    use basicgeometry
    use triangulation
    use collection
    use scalarpde
    use domainintegration

  !<description>
    ! This subroutine is called during the matrix assembly. It has to compute
    ! the coefficients in front of the terms of the bilinear form.
    !
    ! The routine accepts a set of elements and a set of points on these
    ! elements (cubature points) in real coordinates.
    ! According to the terms in the bilinear form, the routine has to compute
    ! simultaneously for all these points and all the terms in the bilinear form
    ! the corresponding coefficients in front of the terms.
  !</description>

  !<input>
    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.; test space.
    type(t_spatialDiscretisation), intent(IN)                   :: rdiscretisationTest

    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.; trial space.
    type(t_spatialDiscretisation), intent(IN)                   :: rdiscretisationTrial

    ! The trilinear form which is currently being evaluated:
    type(t_trilinearForm), intent(IN)                            :: rform

    ! Number of elements, where the coefficients must be computed.
    integer, intent(IN)                        :: nelements

    ! Number of points per element, where the coefficients must be computed
    integer, intent(IN)                                         :: npointsPerElement

    ! This is an array of all points on all the elements where coefficients
    ! are needed.
    ! DIMENSION(dimension,npointsPerElement,nelements)
    real(DP), dimension(:,:,:), intent(IN)  :: Dpoints

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(#local DOF's in trial space,nelements)
    integer, dimension(:,:), intent(IN) :: IdofsTrial

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(#local DOF's in test space,nelements)
    integer, dimension(:,:), intent(IN) :: IdofsTest

    ! This is a t_domainIntSubset structure specifying more detailed information
    ! about the element set that is currently being integrated.
    ! It's usually used in more complex situations (e.g. nonlinear matrices).
    type(t_domainIntSubset), intent(IN)              :: rdomainIntSubset

    ! Optional: A collection structure to provide additional
    ! information to the coefficient routine.
    type(t_collection), intent(INOUT), optional ,target     :: rcollection

  !</input>

  !<output>
    ! A list of all coefficients in front of all terms in the bilinear form -
    ! for all given points on all given elements.
    !   DIMENSION(itermCount,npointsPerElement,nelements)
    ! with itermCount the number of terms in the bilinear form.
    real(DP), dimension(:,:,:), intent(OUT)                      :: Dcoefficients
  !</output>

  !</subroutine>
    ! local variables
    ! Values of the FE function at the points specified by Dpoints.
    ! DIMENSION(itermCount, npoints, nelements).
    real(DP), dimension(:,:,:), allocatable :: Dvalues_Y

    integer :: i, j

	! rInnervector is to save rvector from previous step
    type(t_vectorblock),pointer :: rOutervector

  !</output>

  !</subroutine>

!  Dcoefficients = 0.0_DP

    if (present(rcollection)) then

!MCai, p_rvectorQuickAccess2 is for rNSvector
      rOutervector=>rcollection%p_rvectorQuickAccess2
      allocate(Dvalues_Y(1,npointsPerElement,nelements))

! We need function values at quad points:RvectorBlock(2) for 2nd component of vel
      call fevl_evaluate_sim4 (rOutervector%RvectorBlock(2), &
	                         rdomainIntSubset, DER_FUNC, Dvalues_Y, 1)

! Dcoefficients only have 1 itemcount
      do i = 1,nelements
        do j = 1, npointsPerElement
          ! MCai: {\bf u} \cdot \grad \phi
          ! Dcoefficients have 2 items?
          Dcoefficients(1,j,i)=Dvalues_Y(1,j,i)
        end do
      end do

      deallocate(Dvalues_Y)
    end if

  end subroutine

! ***************************************************************************

  !<subroutine>

  subroutine coeff_VarMass (rdiscretisationTrial,rdiscretisationTest,rform, &
                  nelements,npointsPerElement,Dpoints, &
                  IdofsTrial,IdofsTest,rdomainIntSubset, &
                  Dcoefficients,rcollection)

    use basicgeometry
    use triangulation
    use collection
    use scalarpde
    use domainintegration

  !<description>
    ! This subroutine is called during the matrix assembly. It gives the coeff
	! for variable dependent mass matrix: the coefficient depends on c.
    !
  !</description>

  !<input>
    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.; trial space.
    type(t_spatialDiscretisation), intent(IN)                   :: rdiscretisationTrial

    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.; test space.
    type(t_spatialDiscretisation), intent(IN)                   :: rdiscretisationTest

    ! The bilinear form which is currently being evaluated:
    type(t_bilinearForm), intent(IN)                            :: rform

    ! Number of elements, where the coefficients must be computed.
    integer, intent(IN)                                         :: nelements

    ! Number of points per element, where the coefficients must be computed
    integer, intent(IN)                                         :: npointsPerElement

    ! This is an array of all points on all the elements where coefficients
    ! are needed.
    ! Remark: This usually coincides with rdomainSubset%p_DcubPtsreal.
    ! DIMENSION(dimension,npointsPerElement,nelements)
    real(DP), dimension(:,:,:), intent(IN)  :: Dpoints

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(#local DOF's in trial space,nelements)
    integer, dimension(:,:), intent(IN) :: IdofsTrial

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(#local DOF's in test space,nelements)
    integer, dimension(:,:), intent(IN) :: IdofsTest

    ! This is a t_domainIntSubset structure specifying more detailed information
    ! about the element set that is currently being integrated.
    ! It's usually used in more complex situations (e.g. nonlinear matrices).
    type(t_domainIntSubset), intent(IN)              :: rdomainIntSubset

    ! Optional: A collection structure to provide additional
    ! information to the coefficient routine.
    type(t_collection), intent(INOUT), optional      :: rcollection

  !</input>

  !<output>
    ! A list of all coefficients in front of all terms in the bilinear form -
    ! for all given points on all given elements.
    !   DIMENSION(itermCount,npointsPerElement,nelements)
    ! with itermCount the number of terms in the bilinear form.
    real(DP), dimension(:,:,:), intent(OUT)                      :: Dcoefficients
  !</output>

  !</subroutine>
    ! local variables
    ! Values of the FE function at the points specified by Dpoints.
    ! DIMENSION(itermCount, npoints, nelements).
    real(DP), dimension(:,:,:), allocatable :: Dvalues

    integer :: i, j

	! rInnervector is to save rvector from previous step
    type(t_vectorblock),pointer :: rInnervector
    real(DP) :: f_val
  !</output>

  !</subroutine>

! we treat the source term explicitly (f(\phi(t_n)), \psi)
    if (present(rcollection)) then

!Mcai, we need to modify something here
      rInnervector=>rcollection%p_rvectorQuickAccess1
      allocate(Dvalues(1,npointsPerElement,nelements))

! We need function values at quad points
      call fevl_evaluate_sim4 (rInnervector%RvectorBlock(1), &
	                         rdomainIntSubset, DER_FUNC, Dvalues, 1)

! Dcoefficients only have 1 itemcount
      do i = 1,nelements
        do j = 1, npointsPerElement
! Debug, check Dvalues are correct
!           print *, Dvalues(1, j, i)
	      call Density_fun(Dvalues(1,j,i), f_val)
! Dcoefficients only have 1 item
          Dcoefficients(1,j,i)=f_val
        end do
      end do

      deallocate(Dvalues)

    end if

  end subroutine

  subroutine Density_fun(c, f_val)
  real(DP), intent(IN) :: c
  ! f_val is the mobility
  real(DP), intent(INOUT) :: f_val
  ! local variable
	! Two constant densities
	real(DP) :: rho_1=1.0_DP
	real(DP) :: rho_2=1.0_DP

    f_val=rho_1*(1.0_DP+c)/2.0_DP+rho_2*(1.0_DP-c)/2.0_DP

  end subroutine

! ***************************************************************************
  !<subroutine>

  subroutine coeff_VarLaplace (rdiscretisationTrial,rdiscretisationTest,rform, &
                  nelements,npointsPerElement,Dpoints, &
                  IdofsTrial,IdofsTest,rdomainIntSubset, &
                  Dcoefficients,rcollection)

    use basicgeometry
    use triangulation
    use collection
    use scalarpde
    use domainintegration

  !<description>
    ! This subroutine is called during the matrix assembly. It is used to assemble
	! variable coefficient Laplace matrix, the coefficient depends on c.
  !</description>

  !<input>
    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.; trial space.
    type(t_spatialDiscretisation), intent(IN)                   :: rdiscretisationTrial

    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.; test space.
    type(t_spatialDiscretisation), intent(IN)                   :: rdiscretisationTest

    ! The bilinear form which is currently being evaluated:
    type(t_bilinearForm), intent(IN)                            :: rform

    ! Number of elements, where the coefficients must be computed.
    INTEGER, intent(IN)                                         :: nelements

    ! Number of points per element, where the coefficients must be computed
    integer, intent(IN)                                         :: npointsPerElement

    ! This is an array of all points on all the elements where coefficients
    ! are needed.
    ! Remark: This usually coincides with rdomainSubset%p_DcubPtsreal.
    ! DIMENSION(dimension,npointsPerElement,nelements)
    real(DP), dimension(:,:,:), intent(IN)  :: Dpoints

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(#local DOF's in trial space,nelements)
    INTEGER, DIMENSION(:,:), intent(IN) :: IdofsTrial

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(#local DOF's in test space,nelements)
    INTEGER, DIMENSION(:,:), intent(IN) :: IdofsTest

    ! This is a t_domainIntSubset structure specifying more detailed information
    ! about the element set that is currently being integrated.
    ! It's usually used in more complex situations (e.g. nonlinear matrices).
    type(t_domainIntSubset), intent(IN)              :: rdomainIntSubset

    ! Optional: A collection structure to provide additional
    ! information to the coefficient routine.
    type(t_collection), intent(INOUT), optional      :: rcollection

  !</input>

  !<output>
    ! A list of all coefficients in front of all terms in the bilinear form -
    ! for all given points on all given elements.
    !   DIMENSION(itermCount,npointsPerElement,nelements)
    ! with itermCount the number of terms in the bilinear form.
    real(DP), dimension(:,:,:), intent(OUT)                      :: Dcoefficients
  !</output>

  !</subroutine>
    ! local variables
    ! Values of the FE function at the points specified by Dpoints.
    ! DIMENSION(itermCount, npoints, nelements).
    real(DP), dimension(:,:,:), allocatable :: Dvalues

    integer :: i, j

	! rInnervector is to save rvector from previous step
    type(t_vectorblock),pointer :: rInnervector
    real(DP) :: f_val
  !</output>

  !</subroutine>

!  Dcoefficients = 0.0_DP

! we treat the source term explicitly (f(\phi(t_n)), \psi)
    if (present(rcollection)) then

!Mcai, we need to modify something here
      rInnervector=>rcollection%p_rvectorQuickAccess1
      allocate(Dvalues(1,npointsPerElement,nelements))

! We need function values at quad points
      call fevl_evaluate_sim4 (rInnervector%RvectorBlock(1), &
	                         rdomainIntSubset, DER_FUNC, Dvalues, 1)

! Dcoefficients only have 2 itemcount
      do i = 1,nelements
        do j = 1, npointsPerElement
! Debug, check Dvalues are correct
!           print *, Dvalues(1, j, i)
	      call Mobility_fun(Dvalues(1,j,i), f_val)
! Dcoefficients have 2 items: because it corresponds to Laplace
          Dcoefficients(1,j,i)=f_val
		  Dcoefficients(2,j,i)=f_val
        end do
      end do
      deallocate(Dvalues)
    end if

  end subroutine

! MCai, we need to rewrite Laplace term for CH model, because it is \grad (w/\rho(c))
! we need to use chain role to calculate it.

  subroutine Mobility_fun(c, f_val)
  real(DP), intent(IN) :: c
  ! f_val is the mobility
  real(DP), intent(INOUT) :: f_val
  ! local variable
    real(DP) :: b, rho
	! Two constant densities
	real(DP) :: rho_1=1.0_DP
	real(DP) :: rho_2=1.0_DP

	b=max(1.0_DP-c**2, 0.0_DP)
	b=b**2

    rho=1.0_DP + (c-1.0_DP)*(rho_1-rho_2)/(2.0_DP*rho_1)
    f_val=b/(rho**2)

  end subroutine

!************************************************************************************
  subroutine CH_initCollectForAssembly (rCHproblem,rcollection)

!<description>
  ! This subroutine is an auxiliary subroutine called by the CC2D framework
  ! and has usually not to be changed by the user.
  !
  ! The subroutine prepares the collection rcollection to be passed to callback
  ! routines for assembling boundary conditions or RHS vectors. It is
  ! called directly prior to the assembly to store problem-specific information
  ! in the quick-access arrays of the collection.
  ! Basically speaking, the routine stores information about whether thw problem
  ! is stationary, nonstationary or about the current simulation time.
!</description>

!<input>
  ! Problem structure with all problem relevant data.
  type(t_CHproblem), intent(IN) :: rCHproblem
!</input>

!<inputoutput>
  ! Collection structure to be initialised.
  type(t_collection), intent(INOUT) :: rcollection
!</inputoutput>

!</subroutine>

    ! In a nonstationary simulation, save the simulation time as well as the
    ! minimum and maximum time to the quick-access array of the collection,
    ! so it can be accessed in the callback routines!
    rcollection%Iquickaccess(1) = rCHproblem%itimedependence
    select case (rCHproblem%itimedependence)
    case (0)
      ! Stationary simulation
      rcollection%Dquickaccess(1) = 0.0_DP
      rcollection%Dquickaccess(2) = 0.0_DP
      rcollection%Dquickaccess(3) = 0.0_DP
    case (1)
      rcollection%Dquickaccess(1) = rCHproblem%rtimedependence%dtime
      rcollection%Dquickaccess(2) = rCHproblem%rtimedependence%dtimemin
      rcollection%Dquickaccess(3) = rCHproblem%rtimedependence%dtimemax
    end select

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine coeff_RHS_phi (rdiscretisation,rform, &
                  nelements,npointsPerElement,Dpoints, &
                  IdofsTest,rdomainIntSubset,&
                  Dcoefficients,rcollection)

    use basicgeometry
    use triangulation
    use collection
    use scalarpde
    use domainintegration

  !<description>
    ! This subroutine is called during the vector assembly. It has to compute
    ! the coefficients in front of the terms of the linear form.
    !
    ! The routine accepts a set of elements and a set of points on these
    ! elements (cubature points) in real coordinates.
    ! According to the terms in the linear form, the routine has to compute
    ! simultaneously for all these points and all the terms in the linear form
    ! the corresponding coefficients in front of the terms.
    !
    ! NOTE: The current simulation time is available via the collection
    ! rcollection in two ways:
    !  a) Parameter "TIME"
    !  b) Via the quick-access element Dquickaccess (1)
  !</description>

  !<input>
    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.
    type(t_spatialDiscretisation), intent(IN)                   :: rdiscretisation

    ! The linear form which is currently to be evaluated:
    type(t_linearForm), intent(IN)                              :: rform

    ! Number of elements, where the coefficients must be computed.
    integer, intent(IN)                                         :: nelements

    ! Number of points per element, where the coefficients must be computed
    integer, intent(IN)                                         :: npointsPerElement

    ! This is an array of all points on all the elements where coefficients
    ! are needed.
    ! Remark: This usually coincides with rdomainSubset%p_DcubPtsreal.
    ! DIMENSION(dimension,npointsPerElement,nelements)
    real(DP), DIMENSION(:,:,:), intent(IN)  :: Dpoints

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(#local DOF's in test space,nelements)
    INTEGER, DIMENSION(:,:), intent(IN) :: IdofsTest

    ! This is a t_domainIntSubset structure specifying more detailed information
    ! about the element set that is currently being integrated.
    ! It's usually used in more complex situations (e.g. nonlinear matrices).
    type(t_domainIntSubset), intent(IN)              :: rdomainIntSubset

    ! Optional: A collection structure to provide additional
    ! information to the coefficient routine.
    type(t_collection), intent(INOUT), OPTIONAL      :: rcollection

  !</input>

  !<output>
    ! A list of all coefficients in front of all terms in the linear form -
    ! for all given points on all given elements.
    !   DIMENSION(itermCount,npointsPerElement,nelements)
    ! with itermCount the number of terms in the linear form.
    real(DP), DIMENSION(:,:,:), intent(OUT)                      :: Dcoefficients
  !</output>

  !</subroutine>

    Dcoefficients(:,:,:) = 0.0_DP

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine coeff_RHS_w (rdiscretisation,rform, &
                  nelements,npointsPerElement,Dpoints, &
                  IdofsTest,rdomainIntSubset,&
                  Dcoefficients,rcollection)

    use basicgeometry
    use triangulation
    use collection
    use scalarpde
    use domainintegration

  !<description>
    ! This subroutine is called during the vector assembly. It has to compute
    ! the coefficients in front of the terms of the linear form.
    !
    ! The routine accepts a set of elements and a set of points on these
    ! elements (cubature points) in real coordinates.
    ! According to the terms in the linear form, the routine has to compute
    ! simultaneously for all these points and all the terms in the linear form
    ! the corresponding coefficients in front of the terms.
    !
    ! NOTE: The current simulation time is available via the collection
    ! rcollection in two ways:
    !  a) Parameter "TIME"
    !  b) Via the quick-access element Dquickaccess (1)
  !</description>

  !<input>
    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.
    type(t_spatialDiscretisation), intent(IN)                   :: rdiscretisation

    ! The linear form which is currently to be evaluated:
    type(t_linearForm), intent(IN)                              :: rform

    ! Number of elements, where the coefficients must be computed.
    integer, intent(IN)                                         :: nelements

    ! Number of points per element, where the coefficients must be computed
    integer, intent(IN)                                         :: npointsPerElement

    ! This is an array of all points on all the elements where coefficients
    ! are needed.
    ! Remark: This usually coincides with rdomainSubset%p_DcubPtsreal.
    ! DIMENSION(dimension,npointsPerElement,nelements)
    real(DP), DIMENSION(:,:,:), intent(IN)  :: Dpoints

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(#local DOF's in test space,nelements)
    INTEGER, DIMENSION(:,:), intent(IN) :: IdofsTest

    ! This is a t_domainIntSubset structure specifying more detailed information
    ! about the element set that is currently being integrated.
    ! It's usually used in more complex situations (e.g. nonlinear matrices).
    type(t_domainIntSubset), intent(IN)              :: rdomainIntSubset

    ! Optional: A collection structure to provide additional
    ! information to the coefficient routine.
    type(t_collection), intent(INOUT), OPTIONAL      :: rcollection

  !</input>

  !<output>
    ! A list of all coefficients in front of all terms in the linear form -
    ! for all given points on all given elements.
    !   DIMENSION(itermCount,npointsPerElement,nelements)
    ! with itermCount the number of terms in the linear form.
    real(DP), DIMENSION(:,:,:), intent(OUT)                      :: Dcoefficients
  !</output>

  !</subroutine>

    Dcoefficients = 0.0_DP

  end subroutine

   ! ***************************************************************************

!<subroutine>

  subroutine getBoundaryValues (Icomponents,rdiscretisation,rboundaryRegion,ielement, &
                                   cinfoNeeded,iwhere,dwhere, Dvalues, rcollection)

  use collection
  use spatialdiscretisation
  use discretebc

!<description>
  ! This subroutine is called during the discretisation of boundary
  ! conditions. It calculates a special quantity on the boundary, which is
  ! then used by the discretisation routines to generate a discrete
  ! 'snapshot' of the (actually analytic) boundary conditions.
!</description>

!<input>
  ! Component specifier.
  ! For Dirichlet boundary:
  !   Icomponents(1) defines the number of the boundary component, the value
  !   should be calculated for (e.g. 1=1st solution component, e.g. X-velocitry,
  !   2=2nd solution component, e.g. Y-velocity,...)
  integer, DIMENSION(:), intent(IN)                           :: Icomponents

  ! The discretisation structure that defines the basic shape of the
  ! triangulation with references to the underlying triangulation,
  ! analytic boundary boundary description etc.
  type(t_spatialDiscretisation), intent(IN)                   :: rdiscretisation

  ! Boundary region that is currently being processed.
  type(t_boundaryRegion), intent(IN)                          :: rboundaryRegion

  ! The element number on the boundary which is currently being processed
  integer(I32), intent(IN)                                    :: ielement

  ! The type of information, the routine should calculate. One of the
  ! DISCBC_NEEDxxxx constants. Depending on the constant, the routine has
  ! to return one or multiple information value in the result array.
  integer, intent(IN)                                         :: cinfoNeeded

  ! A reference to a geometric object where information should be computed.
  ! cinfoNeeded=DISCBC_NEEDFUNC :
  !   iwhere = number of the point in the triangulation or
  !          = 0, if only the parameter value of the point is known; this
  !               can be found in dwhere,
  ! cinfoNeeded=DISCBC_NEEDDERIV :
  !   iwhere = number of the point in the triangulation or
  !          = 0, if only the parameter value of the point is known; this
  !               can be found in dwhere,
  ! cinfoNeeded=DISCBC_NEEDINTMEAN :
  !   iwhere = number of the edge where the value integral mean value
  !            should be computed
  integer(I32), intent(IN)                                     :: iwhere

  ! A reference to a geometric object where information should be computed.
  ! cinfoNeeded=DISCBC_NEEDFUNC :
  !   dwhere = parameter value of the point where the value should be computed,
  ! cinfoNeeded=DISCBC_NEEDDERIV :
  !   dwhere = parameter value of the point where the value should be computed,
  ! cinfoNeeded=DISCBC_NEEDINTMEAN :
  !   dwhere = 0 (not used)
  real(DP), intent(IN)                                        :: dwhere

  ! Optional: A collection structure to provide additional
  ! information to the coefficient routine.
!  type(t_collection), intent(IN), OPTIONAL      :: rcollection
!=======
  type(t_collection), intent(INOUT), optional                 :: rcollection

!</input>

!<output>
  ! This array receives the calculated information. If the caller
  ! only needs one value, the computed quantity is put into Dvalues(1).
  ! If multiple values are needed, they are collected here (e.g. for
  ! DISCBC_NEEDDERIV: Dvalues(1)=x-derivative, Dvalues(2)=y-derivative,...)
  real(DP), DIMENSION(:), intent(OUT)                         :: Dvalues
!</output>

!</subroutine>

  ! To get the X/Y-coordinates of the boundary point, use:
  !
  ! real(DP) :: dx,dy
  !
  ! call boundary_getCoords(rdiscretisation%p_rboundary, &
  !     rboundaryRegion%iboundCompIdx, dwhere, dx, dy)

  ! Return zero Dirichlet boundary values for all situations.
  Dvalues(1) = 0.0_DP

  IF ((dwhere .GE. 0.0_DP) .AND. (dwhere .LE. 1.0_DP)) &
    Dvalues(1) = mprim_getParabolicProfile (dwhere,1.0_DP,1.0_DP)

  end subroutine

 ! ***************************************************************************
  !<subroutine>
  ! MCai, we do not need the following subroutine

  subroutine coeff_CahnHilliard (rdiscretisationTrial,rdiscretisationTest,rform, &
                  nelements,npointsPerElement,Dpoints, &
                  IdofsTrial,IdofsTest,rdomainIntSubset, &
                  Dcoefficients,rcollection)

    use basicgeometry
    use triangulation
    use collection
    use scalarpde
    use domainintegration

  !<description>
    ! This subroutine is called during the matrix assembly. It has to compute
    ! the coefficients in front of the terms of the bilinear form.
    !
    ! The routine accepts a set of elements and a set of points on these
    ! elements (cubature points) in real coordinates.
    ! According to the terms in the bilinear form, the routine has to compute
    ! simultaneously for all these points and all the terms in the bilinear form
    ! the corresponding coefficients in front of the terms.
  !</description>

  !<input>
    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.; trial space.
    type(t_spatialDiscretisation), intent(IN)                   :: rdiscretisationTrial

    ! The discretisation structure that defines the basic shape of the
    ! triangulation with references to the underlying triangulation,
    ! analytic boundary boundary description etc.; test space.
    type(t_spatialDiscretisation), intent(IN)                   :: rdiscretisationTest

    ! The bilinear form which is currently being evaluated:
    type(t_bilinearForm), intent(IN)                            :: rform

    ! Number of elements, where the coefficients must be computed.
    integer, intent(IN)                                         :: nelements

    ! Number of points per element, where the coefficients must be computed
    integer, intent(IN)                                         :: npointsPerElement

    ! This is an array of all points on all the elements where coefficients
    ! are needed.
    ! Remark: This usually coincides with rdomainSubset%p_DcubPtsreal.
    ! DIMENSION(dimension,npointsPerElement,nelements)
    real(DP), DIMENSION(:,:,:), intent(IN)  :: Dpoints

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(#local DOF's in trial space,nelements)
    integer, DIMENSION(:,:), intent(IN) :: IdofsTrial

    ! An array accepting the DOF's on all elements trial in the trial space.
    ! DIMENSION(#local DOF's in test space,nelements)
    INTEGER, DIMENSION(:,:), intent(IN) :: IdofsTest

    ! This is a t_domainIntSubset structure specifying more detailed information
    ! about the element set that is currently being integrated.
    ! It's usually used in more complex situations (e.g. nonlinear matrices).
    type(t_domainIntSubset), intent(IN)              :: rdomainIntSubset

    ! Optional: A collection structure to provide additional
    ! information to the coefficient routine.
    type(t_collection), intent(INOUT), OPTIONAL      :: rcollection

  !</input>

  !<output>
    ! A list of all coefficients in front of all terms in the bilinear form -
    ! for all given points on all given elements.
    !   DIMENSION(itermCount,npointsPerElement,nelements)
    ! with itermCount the number of terms in the bilinear form.
    real(DP), DIMENSION(:,:,:), intent(OUT)                      :: Dcoefficients
  !</output>

  !</subroutine>

    Dcoefficients = 1.0_DP

  end subroutine

end module


      implicit real *8 (a-h,o-z)
      integer ns,nt
      double complex zk
      double precision, allocatable :: sources(:,:),targs(:,:)
      double complex, allocatable :: a_vect(:,:,:),lambda(:,:)
      double complex, allocatable :: b_vect(:,:,:)
      double complex, allocatable :: E(:,:,:),divE(:,:),curlE(:,:,:)
      double complex, allocatable :: Eex(:,:,:),divEex(:,:)
      double complex, allocatable :: curlEex(:,:,:)
      double complex ima
      double precision thresh
      double precision t1,t2,omp_get_wtime
      integer ipass(10)
      data ima/(0.0d0,1.0d0)/

      ns = 4001
      nt = 3998

      nd = 2
      zk = 1.1d0 + ima*0.1d0

      allocate(sources(3,ns))
      allocate(a_vect(nd,3,ns),b_vect(nd,3,ns),lambda(nd,ns))

      allocate(targs(3,nt),E(nd,3,nt),divE(nd,nt),curlE(nd,3,nt))

      nttest = 10
      allocate(Eex(nd,3,nttest),divEex(nd,nttest),curlEex(nd,3,nttest))

c
cc  generate sourcrs in the unit cube
c

c
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,j,l)
      do i=1,ns
        sources(1,i) = hkrand(0)**2
        sources(2,i) = hkrand(0)**2
        sources(3,i) = hkrand(0)**2
        do l=1,3
          do j=1,nd
            a_vect(j,l,i) = hkrand(0) + ima*hkrand(0)
            b_vect(j,l,i) = hkrand(0) + ima*hkrand(0)
          enddo
        enddo

        do j=1,nd
          lambda(j,i) = hkrand(0) + ima*hkrand(0)
        enddo
      enddo
C$OMP END PARALLEL DO

c
c   generate targets in the unit cube
c
C$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i)
      do i=1,nt
        targs(1,i) = hkrand(0)**2
        targs(2,i) = hkrand(0)**2
        targs(3,i) = hkrand(0)**2
      enddo
C$OMP END PARALLEL DO

      eps = 1.0d-3
      write(*,*) "=========================================="
      write(*,*) "Testing suite for hfmm3d"
      write(*,'(a,e11.4)') "Requested precision = ",eps

      open(unit=33,file='print_testres.txt',access='append')

      ntests = 6
      do i=1,ntests
        ipass(i) = 0
      enddo

c
cc  test b_vect
cc   with fields
c
      write(6,*) 'interaction: b'
      write(6,*) 'output: fields'
      write(6,*)
      write(6,*)

      ifE = 1
      ifdivE = 0
      ifcurlE = 0
      ifa_vect = 0
      ifb_vect = 1
      iflambda = 0

      call cpu_time(t1)
C$      t1 = omp_get_wtime()

      call emfmm3d(nd,eps,zk,ns,sources,ifa_vect,a_vect,ifb_vect,
     1  b_vect,iflambda,lambda,nt,targs,ifE,E,ifcurlE,curlE,
     2  ifdivE,divE,ier)

      call cpu_time(t2)
C$      t2 = omp_get_wtime()

      call prin2('time=*',t2-t1,1)
      write(14,*) "time=",t2-t1

      thresh = 1.0d-16

      do i=1,nttest
        do l=1,3
          do j=1,nd
            Eex(j,l,i) = 0
          enddo
        enddo
      enddo

      call em3ddirect(nd,zk,ns,sources,ifa_vect,a_vect,ifb_vect,
     1 b_vect,iflambda,lambda,nttest,targs,ifE,Eex,ifcurlE,curlEex,
     2 ifdivE,divEex,thresh)

      erra = 0
      ra = 0
      do i=1,nttest
        do l=1,3
          do j=1,nd
            ra = ra + abs(Eex(j,l,i))**2
            erra = erra + abs(Eex(j,l,i)-E(j,l,i))**2
          enddo
        enddo
      enddo

      erra = sqrt(erra/ra)
      call prin2('rel error in field=*',erra,1)
      if(erra.lt.eps) ipass(1) = 1
      write(6,*)
      write(6,*)
      write(6,*) "====================="
c
cc  test b_vect
cc   with fields, divergence and curl
c
      write(6,*) 'interaction: b'
      write(6,*) 'output: fields, divergence, and curl'
      write(6,*)
      write(6,*)

      ifE = 1
      ifdivE = 1
      ifcurlE = 1
      ifa_vect = 0
      ifb_vect = 1
      iflambda = 0

      call cpu_time(t1)
C$      t1 = omp_get_wtime()
      call emfmm3d(nd,eps,zk,ns,sources,ifa_vect,a_vect,ifb_vect,
     1  b_vect,iflambda,lambda,nt,targs,ifE,E,ifcurlE,curlE,
     2  ifdivE,divE,ier)

      call cpu_time(t2)
C$      t2 = omp_get_wtime()

      call prin2('time=*',t2-t1,1)
      write(14,*) "time=",t2-t1
      thresh = 1.0d-16

      do i=1,nttest
        do l=1,3
          do j=1,nd
            Eex(j,l,i) = 0
            curlEex(j,l,i) = 0
          enddo
        enddo

        do j=1,nd
          divEex(j,i) = 0
        enddo
      enddo

      call em3ddirect(nd,zk,ns,sources,ifa_vect,a_vect,ifb_vect,
     1 b_vect,iflambda,lambda,nttest,targs,ifE,Eex,ifcurlE,curlEex,
     2 ifdivE,divEex,thresh)

      erra = 0
      errc = 0
      errd = 0
      ra = 0
      rc = 0
      rd = 0

      do i=1,nttest
        do l=1,3
          do j=1,nd
            ra = ra + abs(Eex(j,l,i))**2
            rc = rc + abs(curlEex(j,l,i))**2
            erra = erra + abs(Eex(j,l,i)-E(j,l,i))**2
            errc = errc + abs(curlEex(j,l,i)-curlE(j,l,i))**2
          enddo
        enddo

        do j=1,nd
          rd = rd + abs(divEex(j,i))**2
          errd = errd + abs(divEex(j,i)-divE(j,i))**2
        enddo
      enddo

      erra = sqrt(erra/ra)
      errd = sqrt(errd/rd)
      errc = sqrt(errc/rc)

      call prin2('rel error in field=*',erra,1)
      call prin2('rel error in divergence=*',errd,1)
      call prin2('rel error in curl=*',errc,1)
      if(erra.lt.eps.and.errd.lt.eps.and.errc.lt.eps) ipass(2) = 1
      write(6,*)
      write(6,*)
      write(6,*) "====================="

c
cc  test a_vect, lambda
cc   with fields
c
      write(6,*) 'interaction: a,lambda'
      write(6,*) 'output: fields'
      write(6,*)
      write(6,*)

      ifE = 1
      ifdivE = 0
      ifcurlE = 0
      ifa_vect = 1
      ifb_vect = 0
      iflambda = 1

      call cpu_time(t1)
C$     t1 = omp_get_wtime()
      call emfmm3d(nd,eps,zk,ns,sources,ifa_vect,a_vect,ifb_vect,
     1  b_vect,iflambda,lambda,nt,targs,ifE,E,ifcurlE,curlE,
     2  ifdivE,divE,ier)
      call cpu_time(t2)
C$      t2 = omp_get_wtime()

      call prin2('time=*',t2-t1,1)
      write(14,*) "time=",t2-t1

      thresh = 1.0d-16

      do i=1,nttest
        do l=1,3
          do j=1,nd
            Eex(j,l,i) = 0
          enddo
        enddo
      enddo

      call em3ddirect(nd,zk,ns,sources,ifa_vect,a_vect,ifb_vect,
     1 b_vect,iflambda,lambda,nttest,targs,ifE,Eex,ifcurlE,curlEex,
     2 ifdivE,divEex,thresh)

      erra = 0
      ra = 0
      do i=1,nttest
        do l=1,3
          do j=1,nd
            ra = ra + abs(Eex(j,l,i))**2
            erra = erra + abs(Eex(j,l,i)-E(j,l,i))**2
          enddo
        enddo
      enddo

      erra = sqrt(erra/ra)
      call prin2('rel error in field=*',erra,1)
      if(erra.lt.eps) ipass(3) = 1
      write(6,*)
      write(6,*)
      write(6,*) "====================="
c
cc  test a_vect, lambda
cc   with fields, divergence and curl
c

      write(6,*) 'interaction: a,lambda'
      write(6,*) 'output: fields, divergence, and curl'
      write(6,*)
      write(6,*)

      ifE = 1
      ifdivE = 1
      ifcurlE = 1
      ifa_vect = 1
      ifb_vect = 0
      iflambda = 1

      call cpu_time(t1)
C$     t1 = omp_get_wtime()
      call emfmm3d(nd,eps,zk,ns,sources,ifa_vect,a_vect,ifb_vect,
     1  b_vect,iflambda,lambda,nt,targs,ifE,E,ifcurlE,curlE,
     2  ifdivE,divE,ier)

      call cpu_time(t2)
C$      t2 = omp_get_wtime()

      call prin2('time=*',t2-t1,1)
      write(14,*) "time=",t2-t1
      thresh = 1.0d-16

      do i=1,nttest
        do l=1,3
          do j=1,nd
            Eex(j,l,i) = 0
            curlEex(j,l,i) = 0
          enddo
        enddo

        do j=1,nd
          divEex(j,i) = 0
        enddo
      enddo

      call em3ddirect(nd,zk,ns,sources,ifa_vect,a_vect,ifb_vect,
     1 b_vect,iflambda,lambda,nttest,targs,ifE,Eex,ifcurlE,curlEex,
     2 ifdivE,divEex,thresh)

      erra = 0
      errc = 0
      errd = 0
      ra = 0
      rc = 0
      rd = 0

      do i=1,nttest
        do l=1,3
          do j=1,nd
            ra = ra + abs(Eex(j,l,i))**2
            rc = rc + abs(curlEex(j,l,i))**2
            erra = erra + abs(Eex(j,l,i)-E(j,l,i))**2
            errc = errc + abs(curlEex(j,l,i)-curlE(j,l,i))**2
          enddo
        enddo

        do j=1,nd
          rd = rd + abs(divEex(j,i))**2
          errd = errd + abs(divEex(j,i)-divE(j,i))**2
        enddo
      enddo

      erra = sqrt(erra/ra)
      errd = sqrt(errd/rd)
      errc = sqrt(errc/rc)

      call prin2('rel error in field=*',erra,1)
      call prin2('rel error in divergence=*',errd,1)
      call prin2('rel error in curl=*',errc,1)
      if(erra.lt.eps.and.errd.lt.eps.and.errc.lt.eps) ipass(4) = 1
      write(6,*)
      write(6,*)
      write(6,*) "====================="

c
cc  test b_vect,a_vect, lambda
cc   with fields
c
      write(6,*) 'interaction: b,a,lambda'
      write(6,*) 'output: fields'
      write(6,*)
      write(6,*)

      ifE = 1
      ifdivE = 0
      ifcurlE = 0
      ifa_vect = 1
      ifb_vect = 1
      iflambda = 1

      call cpu_time(t1)
C$     t1 = omp_get_wtime()
      call emfmm3d(nd,eps,zk,ns,sources,ifa_vect,a_vect,ifb_vect,
     1  b_vect,iflambda,lambda,nt,targs,ifE,E,ifcurlE,curlE,
     2  ifdivE,divE,ier)

      call cpu_time(t2)
C$      t2 = omp_get_wtime()

      call prin2('time=*',t2-t1,1)
      write(14,*) "time=",t2-t1
      thresh = 1.0d-16

      do i=1,nttest
        do l=1,3
          do j=1,nd
            Eex(j,l,i) = 0
          enddo
        enddo
      enddo

      call em3ddirect(nd,zk,ns,sources,ifa_vect,a_vect,ifb_vect,
     1 b_vect,iflambda,lambda,nttest,targs,ifE,Eex,ifcurlE,curlEex,
     2 ifdivE,divEex,thresh)

      erra = 0
      ra = 0
      do i=1,nttest
        do l=1,3
          do j=1,nd
            ra = ra + abs(Eex(j,l,i))**2
            erra = erra + abs(Eex(j,l,i)-E(j,l,i))**2
          enddo
        enddo
      enddo

      erra = sqrt(erra/ra)
      call prin2('rel error in field=*',erra,1)
      if(erra.lt.eps) ipass(5) = 1
      write(6,*)
      write(6,*)
      write(6,*) "====================="
c
cc  test b_vect,a_vect, lambda
cc   with fields, divergence and curl
c
      write(6,*) 'interaction: b,a,lambda'
      write(6,*) 'output: fields, divergence, and curl'
      write(6,*)
      write(6,*)

      ifE = 1
      ifdivE = 1
      ifcurlE = 1
      ifa_vect = 1
      ifb_vect = 1
      iflambda = 1

      call cpu_time(t1)
C$     t1 = omp_get_wtime()
      call emfmm3d(nd,eps,zk,ns,sources,ifa_vect,a_vect,ifb_vect,
     1  b_vect,iflambda,lambda,nt,targs,ifE,E,ifcurlE,curlE,
     2  ifdivE,divE,ier)

      call cpu_time(t2)
C$      t2 = omp_get_wtime()

      call prin2('time=*',t2-t1,1)
      write(14,*) "time=",t2-t1
      thresh = 1.0d-16

      do i=1,nttest
        do l=1,3
          do j=1,nd
            Eex(j,l,i) = 0
            curlEex(j,l,i) = 0
          enddo
        enddo

        do j=1,nd
          divEex(j,i) = 0
        enddo
      enddo

      call em3ddirect(nd,zk,ns,sources,ifa_vect,a_vect,ifb_vect,
     1 b_vect,iflambda,lambda,nttest,targs,ifE,Eex,ifcurlE,curlEex,
     2 ifdivE,divEex,thresh)

      erra = 0
      errc = 0
      errd = 0
      ra = 0
      rc = 0
      rd = 0

      do i=1,nttest
        do l=1,3
          do j=1,nd
            ra = ra + abs(Eex(j,l,i))**2
            rc = rc + abs(curlEex(j,l,i))**2
            erra = erra + abs(Eex(j,l,i)-E(j,l,i))**2
            errc = errc + abs(curlEex(j,l,i)-curlE(j,l,i))**2
          enddo
        enddo

        do j=1,nd
          rd = rd + abs(divEex(j,i))**2
          errd = errd + abs(divEex(j,i)-divE(j,i))**2
        enddo
      enddo

      erra = sqrt(erra/ra)
      errd = sqrt(errd/rd)
      errc = sqrt(errc/rc)

      call prin2('rel error in field=*',erra,1)
      call prin2('rel error in divergence=*',errd,1)
      call prin2('rel error in curl=*',errc,1)
      if(erra.lt.eps.and.errd.lt.eps.and.errc.lt.eps) ipass(6) = 1
      write(6,*)
      write(6,*)
      write(6,*) "====================="

      isum = 0
      do i=1,ntests
        isum = isum+ipass(i)
      enddo

      write(*,'(a,i2,a,i2,a)') 'Successfully completed ',isum,
     1   ' out of ',ntests,' tests in emfmm3d testing suite'
      write(33,'(a,i2,a,i2,a)') 'Successfully completed ',isum,
     1   ' out of ',ntests,' tests in emfmm3d testing suite'
      close(33)

      stop

      stop
      end


!##############################################################################
!# ****************************************************************************
!# <name> lsfem </name>
!# ****************************************************************************
!# <purpose>
!#
!# This package solves 2D problems using the least-squares FEM.
!# The following PDEs are considered in this code:
!#  - Advection-diffusion-reaction equations (Poisson, diffusion-reaction)
!#  - Navier-Stokes equations (vorticity-based, stress-based)
!#  - non-Newtonian fluid flows (stress-based)
!#
!# </purpose>
!##############################################################################

program lsfem

  use LS_Poisson_MG2D

  use LS_NS_VVP_MG2D
  use LS_NS_VVP_Time_MG2D

  use LS_NS_SVP_MG2D
  use LS_NS_SVP_MG_MAT2D
  use LS_NS_SVP_RT2D

  use LS_SVP_NNew_MG2D

  implicit none

  ! local variables
  character(len=SYS_STRLEN) :: slogdir,slogfile

  ! The very first thing in every application:
  ! Initialise system-wide settings:

  call sys_init()

  ! Initialise the output system.
  !
  ! Normally, we write all the output to the screen and to a file
  ! './log/output.txt'.
  ! In the case that environment variables "$logdir"/"$resultsfile" exists,
  ! we write all the output to that file. This can be used e.g. in
  ! regression tests to compare results to reference results.
  if (sys_getenv_string('LOGDIR',slogdir) .and. &
      sys_getenv_string('RESULTFILE',slogfile)) then
    call output_init (trim(slogdir)//'/'//trim(slogfile))
  else
    call output_init ('./log/output.txt','','./log/error.txt')
  end if

  ! The very second thing in every program:
  ! Initialise the storage management:
  !
  ! 2.) Initialise FEAT 2.0 storage management:
  call storage_init(999, 100)

  ! Call the problem to solve 2D Poisson equation:
  call output_lbrk()
  call output_line('Calculating 2D Poisson')
  call output_lbrk()
  call output_line('Div-Grad-(Curl)-Multigrid')
  call output_line('-------------------------')
  call LS_Poisson_mg

  ! Call the problem to solve 2D Navier-stokes:
  call output_lbrk()
  call output_line('Calculating 2D Navier-Stokes-LSFEM')
  call output_lbrk()
  call output_line('Vorticity-Velocity-Pressure-Multigrid')
  call output_line('-------------------------------------')
  call ls_vvp_mg2d

!  ! Call the problem to solve 2D transient Navier-stokes:
!  call output_lbrk()
!  call output_line('Calculating 2D transient Navier-Stokes-LSFEM')
!  call output_lbrk()
!  call output_line('Vorticity-Velocity-Pressure-Multigrid')
!  call ls_vvp_time_mg2d

  ! Call the problem to solve 2D Navier-stokes:
  call output_lbrk()
  call output_line('----------------------------------')
  call output_line('Calculating 2D Navier-Stokes-LSFEM')
  call output_line('Stress-Velocity-Pressure-Multigrid')
  call output_line('----------------------------------')
   call ls_svp_mg2d

!  ! Call the problem to solve 2D Navier-stokes:
!  call output_lbrk()
!  call output_line('----------------------------------')
!  call output_line('Calculating 2D Navier-Stokes-LSFEM')
!  call output_line('Stress-Velocity-Pressure-Multigrid')
!  call output_line('     Matrix-Based Prol./Rest.     ')
!  call output_line('----------------------------------')
!  call ls_svp_mg_mat2d

!  ! Call the problem to solve Non-Newtonian fluid flow:
!  call output_lbrk()
!  call output_line('----------------------------------')
!  call output_line('Calculating 2D Navier-Stokes-LSFEM')
!  call output_line('Stress-Velocity-Pressure-Multigrid')
!  call output_line('       Non-Newtonian Fluid        ')
!  call output_line('----------------------------------')
!  call ls_svp_nn_mg2d

!  ! Call the problem to solve 2D Navier-stokes:
!  call output_lbrk()
!  call output_line('Calculating 2D Navier-Stokes-LSFEM')
!  call output_lbrk()
!  call output_line('Stress-Velocity-Pressure-Raviart-Thomas')
!  call output_line('---------------------------------------')
!  call ls_svp_rt2d

!  ! Call the problem to solve level-set equation:
!  call output_lbrk()
!  call output_line('Level Set 2D-LSFEM')
!  call output_line('------------------')
!  call ls_levelset

  ! Print out heap statistics - just to check if everything
  ! is cleaned up.
  ! This should display 'Handles in use=0' and 'Memory in use=0'!
  call output_lbrk()
  call storage_info(.true.)

  ! Clean up the storage management, finish
  call storage_done()

end program