*> \brief \b CDRVLS
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE CDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
*                          NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B,
*                          COPYB, C, S, COPYS, WORK, RWORK, IWORK,
*                          NOUT )
*
*       .. Scalar Arguments ..
*       LOGICAL            TSTERR
*       INTEGER            NM, NN, NNB, NNS, NOUT
*       REAL               THRESH
*       ..
*       .. Array Arguments ..
*       LOGICAL            DOTYPE( * )
*       INTEGER            IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
*      $                   NVAL( * ), NXVAL( * )
*       REAL               COPYS( * ), RWORK( * ), S( * )
*       COMPLEX            A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ),
*      $                   WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> CDRVLS tests the least squares driver routines CGELS, CGELSS, CGELSY
*> and CGELSD.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] DOTYPE
*> \verbatim
*>          DOTYPE is LOGICAL array, dimension (NTYPES)
*>          The matrix types to be used for testing.  Matrices of type j
*>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
*>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*>          The matrix of type j is generated as follows:
*>          j=1: A = U*D*V where U and V are random unitary matrices
*>               and D has random entries (> 0.1) taken from a uniform
*>               distribution (0,1). A is full rank.
*>          j=2: The same of 1, but A is scaled up.
*>          j=3: The same of 1, but A is scaled down.
*>          j=4: A = U*D*V where U and V are random unitary matrices
*>               and D has 3*min(M,N)/4 random entries (> 0.1) taken
*>               from a uniform distribution (0,1) and the remaining
*>               entries set to 0. A is rank-deficient.
*>          j=5: The same of 4, but A is scaled up.
*>          j=6: The same of 5, but A is scaled down.
*> \endverbatim
*>
*> \param[in] NM
*> \verbatim
*>          NM is INTEGER
*>          The number of values of M contained in the vector MVAL.
*> \endverbatim
*>
*> \param[in] MVAL
*> \verbatim
*>          MVAL is INTEGER array, dimension (NM)
*>          The values of the matrix row dimension M.
*> \endverbatim
*>
*> \param[in] NN
*> \verbatim
*>          NN is INTEGER
*>          The number of values of N contained in the vector NVAL.
*> \endverbatim
*>
*> \param[in] NVAL
*> \verbatim
*>          NVAL is INTEGER array, dimension (NN)
*>          The values of the matrix column dimension N.
*> \endverbatim
*>
*> \param[in] NNB
*> \verbatim
*>          NNB is INTEGER
*>          The number of values of NB and NX contained in the
*>          vectors NBVAL and NXVAL.  The blocking parameters are used
*>          in pairs (NB,NX).
*> \endverbatim
*>
*> \param[in] NBVAL
*> \verbatim
*>          NBVAL is INTEGER array, dimension (NNB)
*>          The values of the blocksize NB.
*> \endverbatim
*>
*> \param[in] NXVAL
*> \verbatim
*>          NXVAL is INTEGER array, dimension (NNB)
*>          The values of the crossover point NX.
*> \endverbatim
*>
*> \param[in] NNS
*> \verbatim
*>          NNS is INTEGER
*>          The number of values of NRHS contained in the vector NSVAL.
*> \endverbatim
*>
*> \param[in] NSVAL
*> \verbatim
*>          NSVAL is INTEGER array, dimension (NNS)
*>          The values of the number of right hand sides NRHS.
*> \endverbatim
*>
*> \param[in] THRESH
*> \verbatim
*>          THRESH is REAL
*>          The threshold value for the test ratios.  A result is
*>          included in the output file if RESULT >= THRESH.  To have
*>          every test ratio printed, use THRESH = 0.
*> \endverbatim
*>
*> \param[in] TSTERR
*> \verbatim
*>          TSTERR is LOGICAL
*>          Flag that indicates whether error exits are to be tested.
*> \endverbatim
*>
*> \param[out] A
*> \verbatim
*>          A is COMPLEX array, dimension (MMAX*NMAX)
*>          where MMAX is the maximum value of M in MVAL and NMAX is the
*>          maximum value of N in NVAL.
*> \endverbatim
*>
*> \param[out] COPYA
*> \verbatim
*>          COPYA is COMPLEX array, dimension (MMAX*NMAX)
*> \endverbatim
*>
*> \param[out] B
*> \verbatim
*>          B is COMPLEX array, dimension (MMAX*NSMAX)
*>          where MMAX is the maximum value of M in MVAL and NSMAX is the
*>          maximum value of NRHS in NSVAL.
*> \endverbatim
*>
*> \param[out] COPYB
*> \verbatim
*>          COPYB is COMPLEX array, dimension (MMAX*NSMAX)
*> \endverbatim
*>
*> \param[out] C
*> \verbatim
*>          C is COMPLEX array, dimension (MMAX*NSMAX)
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*>          S is REAL array, dimension
*>                      (min(MMAX,NMAX))
*> \endverbatim
*>
*> \param[out] COPYS
*> \verbatim
*>          COPYS is REAL array, dimension
*>                      (min(MMAX,NMAX))
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX array, dimension
*>                      (MMAX*NMAX + 4*NMAX + MMAX).
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is REAL array, dimension (5*NMAX-1)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (15*NMAX)
*> \endverbatim
*>
*> \param[in] NOUT
*> \verbatim
*>          NOUT is INTEGER
*>          The unit number for output.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2015
*
*> \ingroup complex_lin
*
*  =====================================================================
      SUBROUTINE CDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
     $                   NBVAL, NXVAL, THRESH, TSTERR, A, COPYA, B,
     $                   COPYB, C, S, COPYS, WORK, RWORK, IWORK,
     $                   NOUT )
*
*  -- LAPACK test routine (version 3.6.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2015
*
*     .. Scalar Arguments ..
      LOGICAL            TSTERR
      INTEGER            NM, NN, NNB, NNS, NOUT
      REAL               THRESH
*     ..
*     .. Array Arguments ..
      LOGICAL            DOTYPE( * )
      INTEGER            IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
     $                   NVAL( * ), NXVAL( * )
      REAL               COPYS( * ), RWORK( * ), S( * )
      COMPLEX            A( * ), B( * ), C( * ), COPYA( * ), COPYB( * ),
     $                   WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            NTESTS
      PARAMETER          ( NTESTS = 14 )
      INTEGER            SMLSIZ
      PARAMETER          ( SMLSIZ = 25 )
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
      COMPLEX            CONE, CZERO
      PARAMETER          ( CONE = ( 1.0E+0, 0.0E+0 ),
     $                   CZERO = ( 0.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      CHARACTER          TRANS
      CHARACTER*3        PATH
      INTEGER            CRANK, I, IM, IN, INB, INFO, INS, IRANK,
     $                   ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK,
     $                   LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS,
     $                   NFAIL, NRHS, NROWS, NRUN, RANK
      REAL               EPS, NORMA, NORMB, RCOND
*     ..
*     .. Local Arrays ..
      INTEGER            ISEED( 4 ), ISEEDY( 4 )
      REAL               RESULT( NTESTS )
*     ..
*     .. External Functions ..
      REAL               CQRT12, CQRT14, CQRT17, SASUM, SLAMCH
      EXTERNAL           CQRT12, CQRT14, CQRT17, SASUM, SLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           ALAERH, ALAHD, ALASVM, CERRLS, CGELS, CGELSD,
     $                   CGELSS, CGELSY, CGEMM, CLACPY, CLARNV,
     $                   CQRT13, CQRT15, CQRT16, CSSCAL, SAXPY,
     $                   XLAENV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, REAL, SQRT
*     ..
*     .. Scalars in Common ..
      LOGICAL            LERR, OK
      CHARACTER*32       SRNAMT
      INTEGER            INFOT, IOUNIT
*     ..
*     .. Common blocks ..
      COMMON             / INFOC / INFOT, IOUNIT, OK, LERR
      COMMON             / SRNAMC / SRNAMT
*     ..
*     .. Data statements ..
      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
*     ..
*     .. Executable Statements ..
*
*     Initialize constants and the random number seed.
*
      PATH( 1: 1 ) = 'Complex precision'
      PATH( 2: 3 ) = 'LS'
      NRUN = 0
      NFAIL = 0
      NERRS = 0
      DO 10 I = 1, 4
         ISEED( I ) = ISEEDY( I )
   10 CONTINUE
      EPS = SLAMCH( 'Epsilon' )
*
*     Threshold for rank estimation
*
      RCOND = SQRT( EPS ) - ( SQRT( EPS )-EPS ) / 2
*
*     Test the error exits
*
      CALL XLAENV( 9, SMLSIZ )
      IF( TSTERR )
     $   CALL CERRLS( PATH, NOUT )
*
*     Print the header if NM = 0 or NN = 0 and THRESH = 0.
*
      IF( ( NM.EQ.0 .OR. NN.EQ.0 ) .AND. THRESH.EQ.ZERO )
     $   CALL ALAHD( NOUT, PATH )
      INFOT = 0
*
      DO 140 IM = 1, NM
         M = MVAL( IM )
         LDA = MAX( 1, M )
*
         DO 130 IN = 1, NN
            N = NVAL( IN )
            MNMIN = MIN( M, N )
            LDB = MAX( 1, M, N )
*
            DO 120 INS = 1, NNS
               NRHS = NSVAL( INS )
               LWORK = MAX( 1, ( M+NRHS )*( N+2 ), ( N+NRHS )*( M+2 ),
     $                 M*N+4*MNMIN+MAX( M, N ), 2*N+M )
*
               DO 110 IRANK = 1, 2
                  DO 100 ISCALE = 1, 3
                     ITYPE = ( IRANK-1 )*3 + ISCALE
                     IF( .NOT.DOTYPE( ITYPE ) )
     $                  GO TO 100
*
                     IF( IRANK.EQ.1 ) THEN
*
*                       Test CGELS
*
*                       Generate a matrix of scaling type ISCALE
*
                        CALL CQRT13( ISCALE, M, N, COPYA, LDA, NORMA,
     $                               ISEED )
                        DO 40 INB = 1, NNB
                           NB = NBVAL( INB )
                           CALL XLAENV( 1, NB )
                           CALL XLAENV( 3, NXVAL( INB ) )
*
                           DO 30 ITRAN = 1, 2
                              IF( ITRAN.EQ.1 ) THEN
                                 TRANS = 'N'
                                 NROWS = M
                                 NCOLS = N
                              ELSE
                                 TRANS = 'C'
                                 NROWS = N
                                 NCOLS = M
                              END IF
                              LDWORK = MAX( 1, NCOLS )
*
*                             Set up a consistent rhs
*
                              IF( NCOLS.GT.0 ) THEN
                                 CALL CLARNV( 2, ISEED, NCOLS*NRHS,
     $                                        WORK )
                                 CALL CSSCAL( NCOLS*NRHS,
     $                                        ONE / REAL( NCOLS ), WORK,
     $                                        1 )
                              END IF
                              CALL CGEMM( TRANS, 'No transpose', NROWS,
     $                                    NRHS, NCOLS, CONE, COPYA, LDA,
     $                                    WORK, LDWORK, CZERO, B, LDB )
                              CALL CLACPY( 'Full', NROWS, NRHS, B, LDB,
     $                                     COPYB, LDB )
*
*                             Solve LS or overdetermined system
*
                              IF( M.GT.0 .AND. N.GT.0 ) THEN
                                 CALL CLACPY( 'Full', M, N, COPYA, LDA,
     $                                        A, LDA )
                                 CALL CLACPY( 'Full', NROWS, NRHS,
     $                                        COPYB, LDB, B, LDB )
                              END IF
                              SRNAMT = 'CGELS '
                              CALL CGELS( TRANS, M, N, NRHS, A, LDA, B,
     $                                    LDB, WORK, LWORK, INFO )
*
                              IF( INFO.NE.0 )
     $                           CALL ALAERH( PATH, 'CGELS ', INFO, 0,
     $                                        TRANS, M, N, NRHS, -1, NB,
     $                                        ITYPE, NFAIL, NERRS,
     $                                        NOUT )
*
*                             Check correctness of results
*
                              LDWORK = MAX( 1, NROWS )
                              IF( NROWS.GT.0 .AND. NRHS.GT.0 )
     $                           CALL CLACPY( 'Full', NROWS, NRHS,
     $                                        COPYB, LDB, C, LDB )
                              CALL CQRT16( TRANS, M, N, NRHS, COPYA,
     $                                     LDA, B, LDB, C, LDB, RWORK,
     $                                     RESULT( 1 ) )
*
                              IF( ( ITRAN.EQ.1 .AND. M.GE.N ) .OR.
     $                            ( ITRAN.EQ.2 .AND. M.LT.N ) ) THEN
*
*                                Solving LS system
*
                                 RESULT( 2 ) = CQRT17( TRANS, 1, M, N,
     $                                         NRHS, COPYA, LDA, B, LDB,
     $                                         COPYB, LDB, C, WORK,
     $                                         LWORK )
                              ELSE
*
*                                Solving overdetermined system
*
                                 RESULT( 2 ) = CQRT14( TRANS, M, N,
     $                                         NRHS, COPYA, LDA, B, LDB,
     $                                         WORK, LWORK )
                              END IF
*
*                             Print information about the tests that
*                             did not pass the threshold.
*
                              DO 20 K = 1, 2
                                 IF( RESULT( K ).GE.THRESH ) THEN
                                    IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
     $                                 CALL ALAHD( NOUT, PATH )
                                    WRITE( NOUT, FMT = 9999 )TRANS, M,
     $                                 N, NRHS, NB, ITYPE, K,
     $                                 RESULT( K )
                                    NFAIL = NFAIL + 1
                                 END IF
   20                         CONTINUE
                              NRUN = NRUN + 2
   30                      CONTINUE
   40                   CONTINUE
                     END IF
*
*                    Generate a matrix of scaling type ISCALE and rank
*                    type IRANK.
*
                     CALL CQRT15( ISCALE, IRANK, M, N, NRHS, COPYA, LDA,
     $                            COPYB, LDB, COPYS, RANK, NORMA, NORMB,
     $                            ISEED, WORK, LWORK )
*
*                    workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
*
                     LDWORK = MAX( 1, M )
*
*                    Loop for testing different block sizes.
*
                     DO 90 INB = 1, NNB
                        NB = NBVAL( INB )
                        CALL XLAENV( 1, NB )
                        CALL XLAENV( 3, NXVAL( INB ) )
*
*                       Test CGELSY
*
*                       CGELSY:  Compute the minimum-norm solution
*                       X to min( norm( A * X - B ) )
*                       using the rank-revealing orthogonal
*                       factorization.
*
                        CALL CLACPY( 'Full', M, N, COPYA, LDA, A, LDA )
                        CALL CLACPY( 'Full', M, NRHS, COPYB, LDB, B,
     $                               LDB )
*
*                       Initialize vector IWORK.
*
                        DO 70 J = 1, N
                           IWORK( J ) = 0
   70                   CONTINUE
*
*                       Set LWLSY to the adequate value.
*
                        LWLSY = MNMIN + MAX( 2*MNMIN, NB*( N+1 ),
     $                          MNMIN+NB*NRHS )
                        LWLSY = MAX( 1, LWLSY )
*
                        SRNAMT = 'CGELSY'
                        CALL CGELSY( M, N, NRHS, A, LDA, B, LDB, IWORK,
     $                               RCOND, CRANK, WORK, LWLSY, RWORK,
     $                               INFO )
                        IF( INFO.NE.0 )
     $                     CALL ALAERH( PATH, 'CGELSY', INFO, 0, ' ', M,
     $                                  N, NRHS, -1, NB, ITYPE, NFAIL,
     $                                  NERRS, NOUT )
*
*                       workspace used: 2*MNMIN+NB*NB+NB*MAX(N,NRHS)
*
*                       Test 3:  Compute relative error in svd
*                                workspace: M*N + 4*MIN(M,N) + MAX(M,N)
*
                        RESULT( 3 ) = CQRT12( CRANK, CRANK, A, LDA,
     $                                COPYS, WORK, LWORK, RWORK )
*
*                       Test 4:  Compute error in solution
*                                workspace:  M*NRHS + M
*
                        CALL CLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
     $                               LDWORK )
                        CALL CQRT16( 'No transpose', M, N, NRHS, COPYA,
     $                               LDA, B, LDB, WORK, LDWORK, RWORK,
     $                               RESULT( 4 ) )
*
*                       Test 5:  Check norm of r'*A
*                                workspace: NRHS*(M+N)
*
                        RESULT( 5 ) = ZERO
                        IF( M.GT.CRANK )
     $                     RESULT( 5 ) = CQRT17( 'No transpose', 1, M,
     $                                   N, NRHS, COPYA, LDA, B, LDB,
     $                                   COPYB, LDB, C, WORK, LWORK )
*
*                       Test 6:  Check if x is in the rowspace of A
*                                workspace: (M+NRHS)*(N+2)
*
                        RESULT( 6 ) = ZERO
*
                        IF( N.GT.CRANK )
     $                     RESULT( 6 ) = CQRT14( 'No transpose', M, N,
     $                                   NRHS, COPYA, LDA, B, LDB,
     $                                   WORK, LWORK )
*
*                       Test CGELSS
*
*                       CGELSS:  Compute the minimum-norm solution
*                       X to min( norm( A * X - B ) )
*                       using the SVD.
*
                        CALL CLACPY( 'Full', M, N, COPYA, LDA, A, LDA )
                        CALL CLACPY( 'Full', M, NRHS, COPYB, LDB, B,
     $                               LDB )
                        SRNAMT = 'CGELSS'
                        CALL CGELSS( M, N, NRHS, A, LDA, B, LDB, S,
     $                               RCOND, CRANK, WORK, LWORK, RWORK,
     $                               INFO )
*
                        IF( INFO.NE.0 )
     $                     CALL ALAERH( PATH, 'CGELSS', INFO, 0, ' ', M,
     $                                  N, NRHS, -1, NB, ITYPE, NFAIL,
     $                                  NERRS, NOUT )
*
*                       workspace used: 3*min(m,n) +
*                                       max(2*min(m,n),nrhs,max(m,n))
*
*                       Test 7:  Compute relative error in svd
*
                        IF( RANK.GT.0 ) THEN
                           CALL SAXPY( MNMIN, -ONE, COPYS, 1, S, 1 )
                           RESULT( 7 ) = SASUM( MNMIN, S, 1 ) /
     $                                    SASUM( MNMIN, COPYS, 1 ) /
     $                                    ( EPS*REAL( MNMIN ) )
                        ELSE
                           RESULT( 7 ) = ZERO
                        END IF
*
*                       Test 8:  Compute error in solution
*
                        CALL CLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
     $                               LDWORK )
                        CALL CQRT16( 'No transpose', M, N, NRHS, COPYA,
     $                               LDA, B, LDB, WORK, LDWORK, RWORK,
     $                               RESULT( 8 ) )
*
*                       Test 9:  Check norm of r'*A
*
                        RESULT( 9 ) = ZERO
                        IF( M.GT.CRANK )
     $                     RESULT( 9 ) = CQRT17( 'No transpose', 1, M,
     $                                    N, NRHS, COPYA, LDA, B, LDB,
     $                                    COPYB, LDB, C, WORK, LWORK )
*
*                       Test 10:  Check if x is in the rowspace of A
*
                        RESULT( 10 ) = ZERO
                        IF( N.GT.CRANK )
     $                     RESULT( 10 ) = CQRT14( 'No transpose', M, N,
     $                                    NRHS, COPYA, LDA, B, LDB,
     $                                    WORK, LWORK )
*
*                       Test CGELSD
*
*                       CGELSD:  Compute the minimum-norm solution X
*                       to min( norm( A * X - B ) ) using a
*                       divide and conquer SVD.
*
                        CALL XLAENV( 9, 25 )
*
                        CALL CLACPY( 'Full', M, N, COPYA, LDA, A, LDA )
                        CALL CLACPY( 'Full', M, NRHS, COPYB, LDB, B,
     $                               LDB )
*
                        SRNAMT = 'CGELSD'
                        CALL CGELSD( M, N, NRHS, A, LDA, B, LDB, S,
     $                               RCOND, CRANK, WORK, LWORK, RWORK,
     $                               IWORK, INFO )
                        IF( INFO.NE.0 )
     $                     CALL ALAERH( PATH, 'CGELSD', INFO, 0, ' ', M,
     $                                  N, NRHS, -1, NB, ITYPE, NFAIL,
     $                                  NERRS, NOUT )
*
*                       Test 11:  Compute relative error in svd
*
                        IF( RANK.GT.0 ) THEN
                           CALL SAXPY( MNMIN, -ONE, COPYS, 1, S, 1 )
                           RESULT( 11 ) = SASUM( MNMIN, S, 1 ) /
     $                                    SASUM( MNMIN, COPYS, 1 ) /
     $                                    ( EPS*REAL( MNMIN ) )
                        ELSE
                           RESULT( 11 ) = ZERO
                        END IF
*
*                       Test 12:  Compute error in solution
*
                        CALL CLACPY( 'Full', M, NRHS, COPYB, LDB, WORK,
     $                               LDWORK )
                        CALL CQRT16( 'No transpose', M, N, NRHS, COPYA,
     $                               LDA, B, LDB, WORK, LDWORK, RWORK,
     $                               RESULT( 12 ) )
*
*                       Test 13:  Check norm of r'*A
*
                        RESULT( 13 ) = ZERO
                        IF( M.GT.CRANK )
     $                     RESULT( 13 ) = CQRT17( 'No transpose', 1, M,
     $                                    N, NRHS, COPYA, LDA, B, LDB,
     $                                    COPYB, LDB, C, WORK, LWORK )
*
*                       Test 14:  Check if x is in the rowspace of A
*
                        RESULT( 14 ) = ZERO
                        IF( N.GT.CRANK )
     $                     RESULT( 14 ) = CQRT14( 'No transpose', M, N,
     $                                    NRHS, COPYA, LDA, B, LDB,
     $                                    WORK, LWORK )
*
*                       Print information about the tests that did not
*                       pass the threshold.
*
                        DO 80 K = 3, NTESTS
                           IF( RESULT( K ).GE.THRESH ) THEN
                              IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
     $                           CALL ALAHD( NOUT, PATH )
                              WRITE( NOUT, FMT = 9998 )M, N, NRHS, NB,
     $                           ITYPE, K, RESULT( K )
                              NFAIL = NFAIL + 1
                           END IF
   80                   CONTINUE
                        NRUN = NRUN + 12
*
   90                CONTINUE
  100             CONTINUE
  110          CONTINUE
  120       CONTINUE
  130    CONTINUE
  140 CONTINUE
*
*     Print a summary of the results.
*
      CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
 9999 FORMAT( ' TRANS=''', A1, ''', M=', I5, ', N=', I5, ', NRHS=', I4,
     $      ', NB=', I4, ', type', I2, ', test(', I2, ')=', G12.5 )
 9998 FORMAT( ' M=', I5, ', N=', I5, ', NRHS=', I4, ', NB=', I4,
     $      ', type', I2, ', test(', I2, ')=', G12.5 )
      RETURN
*
*     End of CDRVLS
*
      END


      subroutine rand(seed,n,vector)
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C                                                                      %
C Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
C Junior University.  All rights reserved.                             %
C                                                                      %
C The programs in GSLIB are distributed in the hope that they will be  %
C useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
C responsibility to anyone for the consequences of using them or for   %
C whether they serve any particular purpose or work at all, unless he  %
C says so in writing.  Everyone is granted permission to copy, modify  %
C and redistribute the programs in GSLIB, but only under the condition %
C that this notice and the above copyright notice remain intact.       %
C                                                                      %
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
c---------------------------------------------------------------------
c
c This random number generator generates random numbers in ]0,1[
c Note that if the seed value is zero on the first call, a default
c value of 7931 will be used  in a linear congruential generator to
c generate 55 odd integers for the array 'itab()'. These values are
c preserved by a common statement, so that they may be used in sub-
c sequent calls by setting the seed to zero.If the value of 'seed'
c is greater than zero in a call to the subroutine, then the array
c 'itab' will be initialized and a new seed value will be returned
c by the subroutine. Best results are obtained by making the initial
c call with a seed of your choice and then setting the seed to '0'
c for all subsequent calls.
c
c---------------------------------------------------------------------
      dimension vector(*)
      common /unusual/itab(55),n1,n2,nseed
      integer rn1,seed
c
c Test to see if 55 odd integers must be generated.
c
      if((seed.gt.0).or.(nseed.lt.1)) then
            nseed = seed
            if(seed.le.0) nseed  = 7931
            do i=1,55
                  rn1=mod(nseed*9069,32768)
                  if(mod(rn1,2).eq.0) rn1 = rn1-1
                  itab(i) = rn1
                  nseed = rn1
            end do
            n1 = 0
            n2 = 24
      endif
c
c Generate "n" random components for the vector "VECTOR"
c
      do i=1,n
            itab(55-n1) = mod(itab(55-n2)*itab(55-n1),32768)
            vector(i)   = abs(float(itab(55-n1))/float(32768))
            n1 = mod(n1+1,55)
            n2 = mod(n2+1,55)
      end do
      if(seed.gt.0) seed=nseed
c
c Return with the vector of random numbers:
c
      return
      end


module variables
integer,parameter::N=20000
integer,parameter:: Avg_degree=10
integer,parameter::half_degree=Avg_degree/2
real(8),parameter::Pi=60./100. !Rewiring
integer,dimension(N*half_degree,2):: connecttable
real(8) p
end module

program WS
use variables;
implicit none
integer i,j,candidate,nconect
integer FirstNode,SecondNode
integer Alt_First,Alt_Second

!Generate the ordered Network
nconect=0
do i=1,N
do j=1,half_degree
	SecondNode=i+j
	if (SecondNode>N) SecondNode=SecondNode-N
	nconect=nconect+1
	connecttable(nconect,1)=i
	connecttable(nconect,2)=SecondNode
enddo
enddo

!Rewire Attempt
do i=1,nconect
	FirstNode= connecttable(i,1)
	SecondNode= connecttable(i,2)
	p=rand()
	if (p<Pi) then
	!Rewire
		333 continue
		!Choose a candidate for rewiring
		p=rand()
		candidate=int(p*N+1)
		if (candidate==FirstNode) goto 333
	!Test that connection is not repeated
	do j=1,nconect
		if (i==j) cycle
		Alt_First= connecttable(j,1)
		Alt_Second= connecttable(j,2)

	if ((FirstNode-Alt_First)**2+(candidate-Alt_Second)**2==0) goto 333
	if ((FirstNode-Alt_Second)**2+(candidate-Alt_Second)**2==0) goto 333
	enddo
	connecttable(i,2)=candidate
	endif
enddo

!Write Matrix
open(10,file="MyMatrix.txt",status="unknown")

do i=1,nconect
write(10,*) connecttable(i,:)
enddo

end program


      PROGRAM T4
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C                    TRAVAIL FLEURY 'T4.FOR'
C                    ~~~~~~~~~~~~~~~~~~~~~~~
C 02.01.97  . ajout de commentaires
C           . division en plusieurs fichiers
C           . réponse Travail #1 & 2
C 06.02.97  . début de réponse Travail #3
C 08.02.97  . correction Travail #3
C           . nettoyage et commentaires
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Var. : IMAX	: Taille du vecteur S
C ~~~~   S	: Vecteur d'allocation dynamique de mémoire
C                 (pour plus de détails, voir ALLOC.FOR)
C        II	: Vecteur contenant les pos. des tabl. dans S
C        MEMORY	: Mémoire libre
C        EPS	: Précision voulue
C        N	: Nbre de variables
C        m	: Nbre de contraintes
C        METH	: Méthode d'opti (1 = Steep. des.; 2 = CG)
C        METHD	: Méthode primale (0) ou duale (1)
C        NCHECK	: Fréquence d'évaluation de l'ASS
C        IASS	: Type de stratégie des contraintes actives
C        ICONST : Problème contraint (1) ou non contraint (0)
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C Rem :.Il faut bien distinguer le contenu du fichier *.DAT
C ~~~   chargé en mémoire et le problème à résoudre. Par expl.,
C       on peut charger un fichier contenant des contraintes
C       linéaires (matrices C et D) et demander au programme de
C       résoudre le problème non contraint. Il ignore alors
C       ces matrices.
C      .Si on charge un Hessien non diagonal et qu'on demande
C       une formulation duale, le prog. ignore les éléments
C       hors diag.
C      .Il n'y a pas de formulation primale pour des
C       contraintes linéaires
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C     Déclaration des variables
C     -------------------------
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (IMAX=10000)
C
      DIMENSION S(IMAX),II(12)
C
C     Définition des variables (clavier/fichier)
C     ------------------------------------------
      EPS=1.D-06
      MEMORY=IMAX
C

      OPEN(UNIT = 2, FILE='Mini.m', STATUS='UNKNOWN')
C
C     Choix de la méthode d'optimisation (SD - CG)
C     --------------------------------------------
   2  WRITE (*,360)
      READ  (*,*) METH
      IF((METH.LT.0).OR.(METH.GT.1)) GOTO 2
C
C     Choix du type de problème (contraint - non contraint)
C     -----------------------------------------------------
      ICONST=1
C
C     Choix de la méthode (primale - duale)
C     -------------------------------------
      METHD=1
C
C     Choix de la stratégie des contraintes actives
C     ---------------------------------------------
      IF(ICONST.EQ.1) THEN
  5      WRITE(*,340)
         READ(*,*)IASS
         IF((IASS.LT.0).OR.(IASS.GT.2)) GOTO 5
         IF(IASS.EQ.2) THEN
            WRITE(*,400)
            READ(*,*)NCHECK
         ENDIF
      ENDIF

 111  N=6
      m=15
      CALL ALLOC(N,II,MEMORY,IERR,m)
C
C     Calcul de C :
C     -------------
      CALL INITC(S(II(3)),S(II(4)),N,m)
C
C     Calcul de x0:
C     -------------
      WRITE(*,*)'Entrez x0 [0.2] :'
      READ(*,*)X0
      DO i=1,N
         S(II(5)+i-1)=X0
      ENDDO
      DO i=1,m
         S(II(10)+i-1)=0.0D0
      ENDDO
      CALL CHKCONT(S(II(5)),S(II(3)),S(II(4)))

      W    = 0.0D0
      ite  = 0
      ITER = 0
C
C     -- Boucle : -----------------------------------------
C
 112  ite=ite+1
      XNORMOLD=0.0D0
      XNORM=DSQRT(DOTPRO(S(II(5)),S(II(5)),N))
      ERROR=DABS(XNORM-XNORMOLD)
      WRITE(*,*)'Erreur       :',ERROR
      WOLD=W
      CALL POIDS(S(II(5)),N,W)
      IF(DABS(WOLD-W).LT.1D-5) THEN
         CLOSE(UNIT=2)
         WRITE(*,*)'Nbre de quad. =',ite
         STOP
      ENDIF
      WRITE(*,*)'------------------------'
      READ(*,*)
C
C     Ecriture dans le fichier 'Mini.m'
C     ---------------------------------
      WRITE(2,*)'IT(',ite,')=',ITER,';'
      WRITE(2,*)'W(',ite,')=',W,';'
      WRITE(2,*)'Err(',ite,')=',ERROR,';'
      DO i=1,6
         WRITE(2,*)'X(',i,',',ite,')=',S(II(5)+i-1),';'
      ENDDO

C     Evaluation de A et b en fct de x:
C     ---------------------------------
      CALL EVALAB(S(II(1)),S(II(2)),S(II(5)),N)
C
C     Appel de la routine de minimisation
C     -----------------------------------
      if(METHD.eq.1) then
         CALL TRANSFO(S(II(1)),S(II(2)),S(II(3)),S(II(4)),S(II(5)),
     #                S(II(8)),S(II(9)),S(II(10)),N,m,F2)
         CALL MINIM2 (S(II(8)),S(II(10)),S(II(9)),S(II(7)),S(II(6)),
     #                EPS,F2,m,METH,IASS,NCHECK,ICONST,
     #                S(II(11)),ITER)
         CALL TRANSF2(S(II(1)),S(II(2)),S(II(3)),S(II(5)),S(II(10)),
     #                N,m)
      ELSE
         CALL MINIM2 (S(II(1)),S(II(5)),S(II(2)),S(II(7)),S(II(6)),
     #                EPS,F,N,METH,IASS,NCHECK,ICONST,S(II(11)),
     #                ITER)
      ENDIF
C
C     Affiche la solution
C     -------------------
C      WRITE(*,320)
C      READ(*,*)
      DO i=1,N
         WRITE(*,330)i,S(II(5)+i-1)
      ENDDO
      CALL CHKCONT(S(II(5)),S(II(3)),S(II(4)))
      GOTO 112
C
C      CLOSE(UNIT=1)
C      STOP
C
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 300  FORMAT(/' Attention : éléments diagonaux du Hessien ignorés!'/)
 310  FORMAT(/' Attention : contraintes linéaires ignorées!'/)
 320  FORMAT(/' <ENTER> pour voir la solution'/)
 330  FORMAT('  X(',I3,') = ',D20.10)
 340  FORMAT(' Active set strategy : 0 = évaluation à chaque it.:'/,
     #       '                     : 1 = attendre un pt stat.   :'/,
     #       '                     : 2 = éval. toutes les n it. :')
 350  FORMAT(/' Nbre de variables   :',I3/,
     #        ' Nbre de contraintes :',I3/)
 360  FORMAT( ' Méthode  : 0 = STEEPEST DESCENT   :'/,
     #        '          : 1 = CONJUGATE GRADIENT :')
 370  FORMAT( ' Problème : 0 = NON CONTRAINT      :'/,
     #        '          : 1 = CONTRAINT          :')
 380  FORMAT( ' Méthode  : 0 = PRIMALE (Xi>=0)    :'/,
     #        '          : 1 = DUALE (c. lin.)    :')
 390  FORMAT( ' Fichier inexistant !')
 400  FORMAT( ' Entrez n :')
 410  FORMAT( ' Nom du fichier de données (0=clavier) :')
 420  FORMAT(/' Attention : Pas de contraintes lin. définies'/,
     #        '   -> Méthode primale utilisée avec Xi>=0'/)
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      END


c####&

      subroutine buildmodel(a,ar,rot,thick,rho,alpha,beta,isoflag,
     &                      pct,trend,plunge,strike,dip,nlay)
c Set up model for use.

        implicit none
        include 'params.h'

c Model variables:
        integer nlay
        real thick(maxlay),rho(maxlay),alpha(maxlay),beta(maxlay)
        real pct(maxlay),trend(maxlay),plunge(maxlay)
        real strike(maxlay),dip(maxlay)
        logical isoflag(maxlay)

c Outputs:
        real a(3,3,3,3,maxlay),ar(3,3,3,3,maxlay,2),rot(3,3,maxlay)

c Scratch variables:
        integer ilay
        real rot_axis(3,3),d_a,d_b,AA,AC,CC,LL,NN,FF,a_temp(3,3,3,3)

c Parameter eta, combined with percentages of P and S anisotropy,
c is sufficient to obtain all coefficients for a hexagonally-symmetric
c medium. Fixed from Farra et al., 1991
c        real eta
c        parameter (eta=1.03)

        do ilay=1,nlay

          if (isoflag(ilay)) then
c Store isotropic coefficients (only 2 are used)
            a(3,3,3,3,ilay) = alpha(ilay)**2.
            a(2,3,2,3,ilay) = beta(ilay)**2.
          else
c Build anisotropic coefficients for a hexagonally-symmetric medium,
c after Farra et al, 1991
            d_a=alpha(ilay)*pct(ilay)/100.
            d_b=beta(ilay)*pct(ilay)/100.
            AA=rho(ilay)*(alpha(ilay) - d_a/2.)**2.
            CC=rho(ilay)*(alpha(ilay) + d_a/2.)**2.
            LL=rho(ilay)*(beta(ilay) + d_b/2.)**2.
            NN=rho(ilay)*(beta(ilay) - d_b/2.)**2.
c ----------
c PA
c
            AC = rho(ilay)*alpha(ilay)**2
            FF=-LL+SQRT((2.*AC)**2-2.*AC*(AA+CC+2.*LL)+(AA+LL)*(CC+LL))
c
c PA
c            FF=eta*(AA-2.*LL)
c ----------
c            write (*,*) 'Anis. params are:',AA,CC,FF,LL,NN
c Get tensor with unrotated axes
            call tritensr(a_temp,AA,CC,FF,LL,NN,rho(ilay))
c Rotate axes:
            rot_axis(1,1)=cos(trend(ilay))*cos(plunge(ilay))
            rot_axis(2,1)=-sin(trend(ilay))
            rot_axis(3,1)=-cos(trend(ilay))*sin(plunge(ilay))
            rot_axis(1,2)=sin(trend(ilay))*cos(plunge(ilay))
            rot_axis(2,2)=cos(trend(ilay))
            rot_axis(3,2)=-sin(trend(ilay))*sin(plunge(ilay))
            rot_axis(1,3)=sin(plunge(ilay))
            rot_axis(2,3)=0.
            rot_axis(3,3)=cos(plunge(ilay))
c            write (*,*) 'rot_axis:',rot_axis
            call rot_tensor(a(1,1,1,1,ilay),a_temp,rot_axis)

          end if
        end do

c        write (*,*) 'build-model: a(:,:,2,3,2)'
c        do ilay=1,3
c          write (*,*) a(ilay,1,2,3,2),a(ilay,2,2,3,2),a(ilay,3,2,3,2)
c        end do

c Make rotator-matrix list:
        call make_rotator(rot,strike,dip,nlay)
c        write (*,*) 'build-model: rot(:,:,3)'
c        do ilay=1,3
c          write (*,*) rot(ilay,1,3),rot(ilay,2,3),rot(ilay,3,3)
c        end do

c Pre-rotate tensors (skip isotropic ones)
        do ilay=1,nlay
          if (.not.(isoflag(ilay))) then
c            Upper interface:
            call rot_tensor(ar(1,1,1,1,ilay,2),a(1,1,1,1,ilay),
     &           rot(1,1,ilay))
c            Lower interface. Bottom layer is a half-space.
            if (ilay .lt. nlay) then
              call rot_tensor(ar(1,1,1,1,ilay,1),a(1,1,1,1,ilay),
     &             rot(1,1,ilay+1))
            end if
          end if
        end do

c        write (*,*) 'build-model: ar(:,:,2,3,2,1)'
c        do ilay=1,3
c          write (*,*) ar(ilay,1,2,3,2,1),ar(ilay,2,2,3,2,1),
c     &                ar(ilay,3,2,3,2,1)
c        end do

      end

c -----------------------------

      subroutine tritensr(a,AA,CC,FF,LL,NN,rho)

c Sets up transversely isotropic tensor with horizontal
c symmetry axis.

        implicit none

        integer i,j,k,l
        real a(3,3,3,3),AA,CC,FF,LL,NN,rho

        do i=1,3
          do j=1,3
            do k=1,3
              do l=1,3
                a(i,j,k,l)=0
              end do
            end do
          end do
        end do

        a(3,3,3,3)=AA/rho
        a(2,2,2,2)=AA/rho
        a(1,1,1,1)=CC/rho

        a(3,3,2,2)=(AA-2*NN)/rho
        a(2,2,3,3)=(AA-2*NN)/rho

        a(3,3,1,1)=FF/rho
        a(1,1,3,3)=FF/rho

        a(2,2,1,1)=FF/rho
        a(1,1,2,2)=FF/rho

        a(2,1,2,1)=LL/rho
        a(1,2,1,2)=LL/rho
        a(1,2,2,1)=LL/rho
        a(2,1,1,2)=LL/rho

        a(1,3,1,3)=LL/rho
        a(3,1,3,1)=LL/rho
        a(1,3,3,1)=LL/rho
        a(3,1,1,3)=LL/rho

        a(3,2,3,2)=NN/rho
        a(2,3,2,3)=NN/rho
        a(3,2,2,3)=NN/rho
        a(2,3,3,2)=NN/rho

      end

c ---------

      subroutine rot_tensor(CR,CC,R)
c Rotate tensor CC according to rotator matrix R. Result is output
c as tensor CR.

        implicit none

        real CC(3,3,3,3),CR(3,3,3,3),R(3,3)
        integer i,j,k,l,a,b,c,d

        do i=1,3
        do j=1,3
        do k=1,3
        do l=1,3

          CR(i,j,k,l)=0

          do a=1,3
          do b=1,3
          do c=1,3
          do d=1,3

            CR(i,j,k,l)=CR(i,j,k,l) + R(a,i)*R(b,j)*R(c,k)*R(d,l)
     &                  * CC(a,b,c,d)

          end do
          end do
          end do
          end do

        end do
        end do
        end do
        end do

      end

c ---------------------------

      subroutine make_rotator(R,strike,dip,nlay)
c Build list of rotator matrices from a list of interface strikes
c and dips. See make_rotator.m for more info.

        implicit none
        include 'params.h'

        real R(3,3,maxlay),strike(maxlay),dip(maxlay)
        integer nlay,layer,i,j

c Topmost rotator is the identity matrix

        do i=1,3
          do j=1,3
            if (i.eq.j) then
              R(i,j,1)=1
            else
              R(i,j,1)=0
            end if
          end do
        end do

c Build other rotators

        do layer=2,nlay

          R(1,1,layer)=cos(strike(layer))
          R(2,1,layer)=sin(strike(layer))
          R(3,1,layer)=0

          R(1,2,layer)=-cos(dip(layer))*sin(strike(layer))
          R(2,2,layer)=cos(dip(layer))*cos(strike(layer))
          R(3,2,layer)=sin(dip(layer))

          R(1,3,layer)=sin(dip(layer))*sin(strike(layer))
          R(2,3,layer)=-sin(dip(layer))*cos(strike(layer))
          R(3,3,layer)=cos(dip(layer))

        end do

c        do layer=1,nlay
c          write (*,*) 'Rotator for',layer,strike(layer),dip(layer)
c          write (*,*) R(1,1,layer),R(1,2,layer),R(1,3,layer)
c          write (*,*) R(2,1,layer),R(2,2,layer),R(2,3,layer)
c          write (*,*) R(3,1,layer),R(3,2,layer),R(3,3,layer)
c        end do
      end


module HP_volume
#include <messenger.h>
    use mod_kinds,              only: rk,ik
    use mod_constants,          only: ZERO,ONE,TWO,HALF

    use type_operator,          only: operator_t
    use type_chidg_worker,      only: chidg_worker_t
    use type_properties,        only: properties_t
    use DNAD_D
    implicit none

    !>
    !!
    !!  @author Nathan A. Wukie
    !!
    !!
    !!
    !!
    !-------------------------------------------------------------------------
    type, extends(operator_t), public :: HP_volume_t

    contains

        procedure   :: init
        procedure   :: compute

    end type HP_volume_t
    !*************************************************************************

    real(rk) :: p_param = 2._rk

contains

    !>
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   8/29/2016
    !!
    !--------------------------------------------------------------------------------
    subroutine init(self)
        class(HP_volume_t),   intent(inout)  :: self

        ! Set operator name
        call self%set_name('Hyperbolized Poisson Volume Operator')

        ! Set operator type
        call self%set_operator_type('Volume Advective Operator')

        ! Set operator equations
        call self%add_primary_field('u')
        call self%add_primary_field('p')
        call self%add_primary_field('q')
        call self%add_primary_field('r')

    end subroutine init
    !********************************************************************************

    !>
    !!
    !!  @author Nathan A. Wukie
    !!
    !!
    !!
    !!
    !------------------------------------------------------------------------------------
    subroutine compute(self,worker,prop)
        class(HP_volume_t),  intent(inout)   :: self
        type(chidg_worker_t),                   intent(inout)   :: worker
        class(properties_t),                    intent(inout)   :: prop

        type(AD_D), allocatable, dimension(:)   ::  &
            u, p, q, r, flux_1, flux_2, flux_3, sumsqr, mag

        !
        ! Interpolate solution to quadrature nodes
        !
        u  = worker%get_field('u','value','element')
        p  = worker%get_field('p','value','element')
        q  = worker%get_field('q','value','element')
        r  = worker%get_field('r','value','element')

        ! Allocate derivatives
        flux_1 = u*ZERO
        flux_2 = u*ZERO
        flux_3 = u*ZERO

        !
        ! u-equation
        !
        sumsqr = p*p + q*q + r*r
        if (abs(p_param-2._rk) > 1.e-8_rk) then
            mag = sumsqr**((p_param-TWO)/TWO)
        else
            mag = sumsqr
            mag = ONE
        end if

        flux_1 = mag*p
        flux_2 = mag*q
        flux_3 = mag*r

!        flux_1 = p
!        flux_2 = q
!        flux_3 = r

        call worker%integrate_volume_flux('u','Advection',flux_1,flux_2,flux_3)

        !
        ! p-equation
        !
        flux_1 = u
        flux_2 = ZERO
        flux_3 = ZERO

        call worker%integrate_volume_flux('p','Advection',flux_1,flux_2,flux_3)

        !
        ! q-equation
        !
        flux_1 = ZERO
        flux_2 = u
        flux_3 = ZERO

        call worker%integrate_volume_flux('q','Advection',flux_1,flux_2,flux_3)

        !
        ! r-equation
        !
        flux_1 = ZERO
        flux_2 = ZERO
        flux_3 = u

        call worker%integrate_volume_flux('r','Advection',flux_1,flux_2,flux_3)

    end subroutine compute
    !****************************************************************************************************

end module HP_volume


  subroutine rotor (sDCM, ar, br, pstar, pr)

! ======================================================================
!
!    Coordinate rotation.
!
!    Called by: ABEL DIRECT8 ISOBAR PRECOF STAT
!
!    ar is the momentum of the emitting system in the CM frame:
!    it defines the z' axis.
!    br is the velocity vector of the CM frame in the lab frame.
!    ar and br define a plane, which contains the x' axis.
!    pstar is the momentum of one of the final state particles in the
!    CM' frame.
!
!    This frame is defined with z' parallel to ar, x' perpendicular
!    to ar, in the plane defined by ar and br, and y' perpendicular
!    to the same plane.  The routine calculates the vector pr, which
!    is the vector of final state particle momentum in the CM frame
!    which has its coordinate axes parallel to those of the lab frame,
!    so pr is easily Lorentz transformed into the lab frame.
!
!   CEM95 written by S. G. Mashnik
!
!   Edited by A. J. Sierk,  LANL  T-2  February, 1996.
!   Modified by A. J. Sierk,  LANL  T-2  March, 1996.
!   Further editing by AJS, July, 1997.
!   Modified by AJS; August, 1997.
!   Comments corrected by AJS, December, 1999.
!   Modified for real*8 by A. J. Sierk, LANL T-16, October, 2003.
!   Edited by AJS, LANL T-2, December, 2011.
!   Edited by LMK, XCP-3, July 2013 (included error protection)
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64
    use standardDCMParams, only : zro, one

    implicit none
    class(StandardDCM), intent(inout) :: sDCM
    real(real64), dimension(3), intent(in)  :: ar
    real(real64), dimension(3), intent(in)  :: br
    real(real64), dimension(3), intent(in)  :: pstar
    real(real64), dimension(3), intent(out) :: pr

    integer(int32) :: ir
    real(real64)   :: alpha2, amod, bmod, cmod, cp, dmod, f2, fac
    real(real64), dimension(3) :: an=zro, bn=zro, cn=zro, dn=zro

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

    amod = sqrt(ar(1)**2 + ar(2)**2 + ar(3)**2)
    bmod = sqrt(br(1)**2 + br(2)**2 + br(3)**2)
    if (amod < div0Lim .and. amod > -div0Lim) then
       amod = div0Lim
       write(sDCM%io%message,1000) "62, 66"
       call sDCM%io%print(4, 3, sDCM%io%message)
    end if
    if (bmod < div0Lim .and. bmod > -div0Lim) then
       bmod = div0Lim
       write(sDCM%io%message,1000) "63, 66"
       call sDCM%io%print(4, 3, sDCM%io%message)
    end if
    cp = zro
    do ir = 1,3
       cp = cp + ar(ir)*br(ir)
       an(ir) = ar(ir)/amod
       bn(ir) = br(ir)/bmod
    end do
!   cp is the cosine of the angle between vectors ar and br.
    cp = cp/(amod*bmod)
    if (abs(cp) > one) cp = sign(one, cp)
!   cn is the cross product of two unit vectors; its magnitude is
!   sin (angle);  redefined cn is the unit vector perpendicular to
!   the plane of ar and br.
    cn(1) = an(2)*bn(3) - an(3)*bn(2)
    cn(2) = an(3)*bn(1) - an(1)*bn(3)
    cn(3) = an(1)*bn(2) - an(2)*bn(1)
    cmod = sqrt(cn(1)**2 + cn(2)**2 + cn(3)**2)
    if (cmod > zro) then
!  The cross product is not exactly 0 to machine precision:
       if (cmod < div0Lim .and. cmod > -div0Lim) then
          cmod = div0Lim
          write(sDCM%io%message,1000) "81"
       call sDCM%io%print(4, 3, sDCM%io%message)
       end if
       fac = one/cmod
       do ir = 1,3
          cn(ir) = cn(ir)*fac
          dn(ir) = bn(ir) - cp*an(ir)
       end do
    else
!   bn is exactly (or anti-) parallel to an to within machine precision:
!   Define an arbitrary coordinate system with an as its z' axis.
       cn(2) = zro
       if (an(3).ne.zro) then
          fac = one/sqrt(an(1)**2 + an(3)**2)   !No check needed because of if statement
          cn(1) =  fac*an(3)
          cn(3) = -fac*an(1)
          if (an(2).ne.zro) then
             dn(1) = an(1)/an(3)   !No check needed because of if statement
             dn(2) = -(an(1)**2 + an(3)**2)/(an(2)*an(3))
             dn(3) = one
          else
             dn(1) = zro
             dn(2) = -one
             dn(3) = zro
          endif
       else
          cn(1) =  zro
          cn(3) = -one
          dn(1) =  an(2)
          dn(2) = -an(1)
          dn(3) =  zro
       endif
    endif
    alpha2 = sqrt(one - cp**2)
    if (alpha2 > 1.0d-6) then
       do ir = 1,3
          pr(ir) = pstar(1)*dn(ir)/alpha2 + pstar(3)*an(ir) &
               + pstar(2)*cn(ir)
       end do
    else
!  an and bn are nearly parallel or antiparallel; round-off may make
!  dmod = zro to computer word length.
       dmod = sqrt(dn(1)**2 + dn(2)**2 + dn(3)**2)
       if (dmod.ne.zro) then
          f2 = one/dmod
       else
          f2 = zro
       endif
       do ir = 1,3
          pr(ir) = pstar(3)*an(ir) + pstar(2)*cn(ir) + &
               pstar(1)*dn(ir)*f2
       end do
    endif

    return

! ======================================================================
1000 format ("Divide by zero error prevented in 'rotor.f90', line(s) ", A)
! ======================================================================

end subroutine rotor


C
C	$Id$
C
      SUBROUTINE CSGRCOEF (SIGMA, D,SD)
      DOUBLE PRECISION SIGMA, D, SD
C
C***********************************************************
C
C                                              From SSRFPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   11/21/96
C
C   This subroutine computes factors involved in the linear
C systems solved by Subroutines CSGRADG and CSSMSGS.
C
C On input:
C
C       SIGMA = Nonnegative tension factor associated with a
C               triangulation arc.
C
C SIGMA is not altered by this routine.
C
C On output:
C
C       D = Diagonal factor.  D = SIG*(SIG*Coshm(SIG) -
C           Sinhm(SIG))/E where E = SIG*Sinh(SIG) - 2*
C           Coshm(SIG).  D > 0, and D = 4 at SIG = 0.
C
C       SD = Off-diagonal factor.  SD = SIG*Sinhm(SIG)/E.
C            SD > 0, and SD = 2 at SIG = 0.
C
C SSRFPACK module required by CSGRCOEF:  CSSNHCSH
C
C Intrinsic function called by CSGRCOEF:  EXP
C
C***********************************************************
C
      DOUBLE PRECISION COSHM, COSHMM, E, EMS, SCM, SIG,
     .                 SINHM, SSINH, SSM
      SIG = SIGMA
      IF (SIG .LT. 1.D-9) THEN
C
C Cubic function:
C
        D = 4.
        SD = 2.
      ELSEIF (SIG .LE. .5) THEN
C
C 0 < SIG .LE. .5.
C
C Use approximations designed to avoid cancellation error
C   in the hyperbolic functions when SIGMA is small.
C
        CALL CSSNHCSH (SIG, SINHM,COSHM,COSHMM)
        E = SIG*SINHM - COSHMM - COSHMM
        D = SIG*(SIG*COSHM-SINHM)/E
        SD = SIG*SINHM/E
      ELSE
C
C SIG > .5.
C
C Scale SINHM, COSHM, and E by 2*EXP(-SIG) in order to
C   avoid overflow when SIGMA is large.
C
        EMS = EXP(-SIG)
        SSINH = 1. - EMS*EMS
        SSM = SSINH - 2.*SIG*EMS
        SCM = (1.-EMS)*(1.-EMS)
        E = SIG*SSINH - SCM - SCM
        D = SIG*(SIG*SCM-SSM)/E
        SD = SIG*SSM/E
      ENDIF
      RETURN
      END


!     PURPOSE  : Solve the Hubbard model using DMFT away from half-filling
! with modified itertive perturbation scheme (MPT)
program hmmpt_matsubara
  USE DMFT_IPT
  USE DMFT_TOOLS
  USE SCIFOR
  implicit none
  real(8)                             :: x(1),D,wmix,energy(3)
  logical                             :: check
  complex(8)                          :: zeta
  logical                             :: converged
  integer                             :: i,iloop,L
  real(8),dimension(:),allocatable    :: wm
  real(8)                             :: xmu0,n,n0,z,docc
  complex(8),dimension(:),allocatable :: sigma,fg,fg0,gamma,sold

  call parse_input_variable(L,"L","inputIPT.conf",default=4096)
  call parse_input_variable(D,"wband","inputIPT.conf",default=1d0,comment="half-bandwidth, energy unit")
  call parse_input_variable(wmix,"wmix","inputIPT.conf",default=0.5d0,comment="mixing parameter")
  call read_input("inputIPT.conf")

  allocate(fg(L))
  allocate(fg0(L))
  allocate(sigma(L))
  allocate(gamma(L))
  allocate(sold(L))
  allocate(wm(L))

  wm = pi/beta*(2*arange(1,L)-1)

  call  get_initial_sigma(Sigma,"Sigma_iw.restart")

  xmu0=xmu

  iloop=0 ; converged=.false.
  do while (.not.converged.AND.iloop<nloop)
     iloop=iloop+1
     write(*,"(A,i5)")"DMFT-loop",iloop
     do i=1,L
        zeta    = xi*wm(i) + xmu - sigma(i)
        fg(i) = gfbethe(wm(i),zeta,D)
     enddo

     !Get the regular Weiss Field: \Gamma(w+xmu)
     gamma = one/(one/fg + sigma)
     n     = ipt_measure_dens_matsubara(fg)

     !Fix the xmu0 w/ condition n0=n
     x(1)=xmu0
     call broydn(mpt_condition_n_eq_n0,x,check,tolf=1d-3,tolmin=1d-4)
     xmu0=x(1)
     sigma = mpt_solve_matsubara(fg0,n,n0,xmu0)
     if(iloop>1)sigma = wmix*sigma + (1.d0-wmix)*sold
     sold = sigma
     z    = ipt_measure_zeta_matsubara(sigma,fg0)
     docc = ipt_measure_docc_matsubara(sigma,fg0)
     n    = ipt_measure_dens_matsubara(fg)
     call splot("obserbables_all.ipt",n,docc,z,append=.true.)
     converged=check_convergence(sigma,dmft_error,Nsuccess,Nloop)
  enddo
  call splot("G_iw.ipt",wm,fg)
  call splot("G0_iw.ipt",wm,fg0)
  call splot("Sigma_iw.ipt",wm,sigma)
  call splot("obserbables_last.ipt",n,docc,z,energy(1),energy(2),energy(3))

contains

  function mpt_condition_n_eq_n0(x) result(funcv)
    implicit none
    real(8),dimension(:),intent(in)  ::  x
    real(8),dimension(size(x))       ::  funcv
    real(8)                          ::  zn0
    xmu0=x(1)
    !Hartree corrected WF is: \tilde{\calG0}^-1 = \calG0^-1 +xmu -xmu0 -Uloc*n
    fg0 = one/(one/gamma +xmu-xmu0-uloc(1)*(n-0.5d0))
    n0  = ipt_measure_dens_matsubara(fg0)
    funcv(1)=n-n0
    write(*,"(3(f13.9))")n,n0,xmu0
  end function mpt_condition_n_eq_n0

  !Get the initial Sigma: either by reading from file or assuming a HF form
  subroutine get_initial_sigma(self,file)
    complex(8),dimension(:) :: self
    real(8),dimension(size(self)) :: wm
    character(len=*)        :: file
    logical                 :: check
    inquire(file=file,exist=check)
    if(check)then
       print*,'Reading sigma'
       open(100,file=file)
       do i=1,size(self)
          read(100,*)wm(i),self(i)
       enddo
       close(100)
    else
       print*,"Using Hartree-Fock self-energy U*(n-1/2) [n=1/2]"
       print*,"===================================="
       n=0.5d0
       self= Uloc(1)*(n-0.5d0)
    endif
  end subroutine get_initial_sigma

end program hmmpt_matsubara


SUBROUTINE checon(loads,oldlds,tol,converged)
!
! This subroutine sets converged to .FALSE. if relative change in loads
! and oldlds is greater than tol and updates oldlds.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::loads(0:),tol
 REAL(iwp),INTENT(IN OUT)::oldlds(0:)
 LOGICAL,INTENT(OUT)::converged
 CONVERGED=.TRUE.
 CONVERGED=(MAXVAL(ABS(loads-oldlds))/MAXVAL(ABS(loads))<=tol)
 oldlds=loads
RETURN
END SUBROUTINE checon


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED is distributed in the hope that it will be useful, but
!    WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Computes the nearest node with respet to (xt,yt,zt)
!! starting from a given elevation.
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] nloc number of local nodes
!> @param[in] xs vertex x-coordinate of local nodes
!> @param[in] ys vertex y-coordinate of local nodes
!> @param[in] zs vertex z-coordinate of local nodes
!> @param[in] xt x-coor current vertex
!> @param[in] yt y-coor current vertex
!> @param[in] zt z-coor current vertex
!> @param[in] elevation z-value from wich we start the search
!> @param[out] nt index of the  nearest node from (xt,yt,zt)
!> @param[out] dist_min minimal distance from (xt,yt,zt)

      subroutine GET_NEAREST_NODE_PGM(nloc,xs,ys,zs,xt,yt,zt,nt,dist_min,elevation)

      implicit none

      integer*4 :: i, nloc, nt

      real*8 :: xt,yt,zt
      real*8 :: elevation
      real*8 :: dist,dist_min

      real*8, dimension(nloc) :: xs, ys, zs

      dist_min = 1.0d30
      nt = 1

      do i = 1,nloc

         if (zs(i) .gt. elevation) then

            dist = (xs(i) - xt)*(xs(i) - xt) + (ys(i) - yt)*(ys(i) - yt) + (zs(i) - zt)*(zs(i) - zt)

            if (dist .lt. dist_min) then
               dist_min = dist; nt = i
            endif

        endif

      enddo

      return
      end subroutine GET_NEAREST_NODE_PGM


program median_statistics
    use, intrinsic :: iso_fortran_env, only : error_unit, input_unit
    implicit none
    integer :: nr_values

    nr_values = get_command_llne_values()
    print '(A, E12.5)', 'median = ', compute_median(input_unit, nr_values)

contains

    function compute_median(unit_nr, nr_values) result(median_value)
        use, intrinsic :: iso_fortran_env, only : error_unit
        use :: quicksort_mod, only : qsort
        implicit none
        integer, value :: unit_nr, nr_values
        real :: median_value
        real, dimension(:), allocatable :: values
        integer :: i, istat
        character(len=1024) :: msg

        allocate (values(nr_values), stat=istat)
        if (istat /= 0) then
            write (unit=error_unit, fmt='(A, I0)') &
                'error: can not allocate array of size ', nr_values
            stop 1
        end if
        do i = 1, nr_values
            read (unit=unit_nr, fmt=*, iostat=istat, iomsg=msg) values(i)
            if (istat /= 0) then
                write (unit=error_unit, fmt='(2A)') &
                    'error: I/O error ', trim(msg)
                stop 2
            end if
        end do
        call qsort(values)
        if (mod(nr_values, 2) == 0) then
            median_value = 0.5*(values(nr_values/2) + values(nr_values/2 + 1))
        else
            median_value = values(nr_values/2 + 1)
        end if
        deallocate (values)
    end function compute_median

    function get_command_llne_values() result(nr_values)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        integer :: nr_values
        character(len=1024) :: buffer

        if (command_argument_count() /= 1) then
            write (unit=error_unit, fmt='(A)') &
                'error: number of values required as argument'
            stop 5
        end if
        call get_command_argument(1, buffer)
        read (buffer, fmt=*) nr_values
    end function get_command_llne_values

end program median_statistics


      subroutine vertical_mean(ff,i_name)
      include 'SIZE'
      include 'TOTAL'

      parameter(nelz=16)

      real ff(lx1,ly1,lz1,lelt)
      real fbar(lz1,nelz)
      real zbar(lz1,nelz)
      real wght(lz1,nelz)
      real work(lz1,nelz)

      integer e,eg,ex,ey,ez,f

      nelxy = nelgv/nelz

      call rzero(fbar,lz1*nelz)
      call rzero(zbar,lz1*nelz)
      call rzero(wght,lz1*nelz)

      f = 5 ! to evaluate surface Jacobian
      do e=1,nelv
         eg = lglel(e)
         call get_exyz(ex,ey,ez,eg,nelxy,1,nelz)
         do k=1,nz1
         do i=1,nx1*ny1
             fbar(k,ez) = fbar(k,ez)+area(i,1,f,e)*ff(i,1,k,e)
             zbar(k,ez) = zbar(k,ez)+area(i,1,f,e)*zm1(i,1,k,e)
             wght(k,ez) = wght(k,ez)+area(i,1,f,e)
         enddo
         enddo
      enddo

      call gop(fbar,work,'+  ',lz1*nelz)
      call gop(zbar,work,'+  ',lz1*nelz)
      call gop(wght,work,'+  ',lz1*nelz)

      do i=1,lz1*nelz
        fbar(i,1)=fbar(i,1)/wght(i,1)
        zbar(i,1)=zbar(i,1)/wght(i,1)
      enddo

      if(nid.eq.0)then
        if(i_name.eq.1)OPEN(10,file="ver_uzte.dat",position="append")
        if(i_name.eq.2)OPEN(10,file="ver_epst.dat",position="append")
        if(i_name.eq.3)OPEN(10,file="ver_epsv.dat",position="append")
        if(i_name.eq.4)OPEN(10,file="ver_temp.dat",position="append")
        if(i_name.eq.5)OPEN(10,file="ver_dtdz.dat",position="append")

        do k=1,nelz
        do i=1,lz1-1
          write(10,*)zbar(i,k),fbar(i,k)
        enddo
        enddo
        CLOSE(10)
      endif

      return
      end
c-----------------------------------------------------------------------
      subroutine pdf_calc(ff,step,i_offset,i_name)
      include 'SIZE'
      include 'TOTAL'

      parameter(npdf=2401)

      real ff(lx1,ly1,lz1,lelt)
      real pdf(npdf)
      real work(npdf)
      real val, vol, offset, wght, norm
      integer e

      call rzero(pdf,npdf)
      call rzero(work,npdf)

      if(i_offset==0) offset=0.0
      if(i_offset==1) offset=int(npdf/2)*step

!-----Volume for aspect ratio=1
      vol=atan(1.0)

      do e=1,nelv
        do k=1,nz1
          do j=1,ny1
            do i=1,nx1

               wght= bm1(i,j,k,e)
               val= ff(i,j,k,e)

               do ipdf=1,npdf
                dm1=(ipdf -1 )*step-offset
                dm2= ipdf     *step-offset

                if((val.ge.dm1).and.(val.lt.dm2))then
                  pdf(ipdf)=pdf(ipdf)+wght
                endif

               enddo
            enddo
          enddo
        enddo
      enddo

      do i=1,npdf
        pdf(i)=pdf(i)/vol
      enddo

      call gop(pdf,work,'+  ',npdf)

!------------------------------------------------------------
      if(nid.eq.0)then

        if(i_name.eq.1)OPEN(10,file="pdf_dudx.dat",position="append")
        if(i_name.eq.2)OPEN(10,file="pdf_epst.dat",position="append")
        if(i_name.eq.3)OPEN(10,file="pdf_epsv.dat",position="append")
        if(i_name.eq.4)OPEN(10,file="pdf_temp.dat",position="append")
        if(i_name.eq.5)OPEN(10,file="pdf_dtdx.dat",position="append")

        do ipdf=1,npdf
          write(10,*) (ipdf-1)*step-offset, pdf(ipdf)
        enddo
        CLOSE(10)

        norm=0.0
        do ipdf=1,npdf
          norm=norm+pdf(ipdf)
        enddo
        if(i_name.eq.1)write(77,*)'dudx',norm
        if(i_name.eq.2)write(77,*)'epsT',norm
        if(i_name.eq.3)write(77,*)'epsv',norm
        if(i_name.eq.4)write(77,*)'Temp',norm
        if(i_name.eq.5)write(77,*)'dTdx',norm

      endif

      return
      end
c-----------------------------------------------------------------------
      subroutine pdf_calc_bulk(ff,step,i_offset,i_name)
      include 'SIZE'
      include 'TOTAL'

      parameter(npdf=2401)

      real ff(lx1,ly1,lz1,lelt)
      real pdf(npdf)
      real work(npdf)
      real val, vol, offset, wght, norm, height1, height2, radius, radiusc
      integer e

!-----Set arrays to zero
      call rzero(pdf,npdf)
      call rzero(work,npdf)

!-----Offset
      if(i_offset==0) offset=0.0
      if(i_offset==1) offset=int(npdf/2)*step

!-----Volume for aspect ratio=1
      radiusc=0.3
      height1=0.2
      height2=0.8
      vol=4*atan(1.0)*radiusc**2*(height2-height1)

      do e=1,nelv
      do k=1,nz1
      do j=1,ny1
      do i=1,nx1
               wght= bm1(i,j,k,e)
               val= ff(i,j,k,e)

	       radius=sqrt(xm1(i,j,k,e)**2+ym1(i,j,k,e)**2)
               IF (radius.le.radiusc) THEN

!-----------------------------------------------------------------------
      if ((zm1(i,j,k,e).ge.height1).and.(zm1(i,j,k,e).le.height2)) then

               do ipdf=1,npdf
                dm1=(ipdf -1 )*step-offset
                dm2= ipdf     *step-offset

                if((val.ge.dm1).and.(val.lt.dm2))then
                  pdf(ipdf)=pdf(ipdf)+wght
                endif

               enddo

               endif
!-----------------------------------------------------------------------

               ENDIF
      enddo
      enddo
      enddo
      enddo

      do i=1,npdf
        pdf(i)=pdf(i)/vol
      enddo

      call gop(pdf,work,'+  ',npdf)

      if(nid.eq.0) then
        if(i_name.eq.1)OPEN(10,file="pdf_dudx_b.dat",position="append")
        if(i_name.eq.2)OPEN(10,file="pdf_epst_b.dat",position="append")
        if(i_name.eq.3)OPEN(10,file="pdf_epsv_b.dat",position="append")
        if(i_name.eq.4)OPEN(10,file="pdf_temp_b.dat",position="append")
        if(i_name.eq.5)OPEN(10,file="pdf_dtdx_b.dat",position="append")

        do ipdf=1,npdf
          write(10,*) (ipdf-1)*step-offset, pdf(ipdf)
        enddo
        CLOSE(10)

        norm=0.0
        do ipdf=1,npdf
          norm=norm+pdf(ipdf)
        enddo
        if(i_name.eq.1)write(78,*)'dudx',norm
        if(i_name.eq.2)write(78,*)'epsT',norm
        if(i_name.eq.3)write(78,*)'epsv',norm
        if(i_name.eq.4)write(78,*)'Temp',norm
        if(i_name.eq.5)write(78,*)'dTdx',norm
      endif

      return
      end
c-----------------------------------------------------------------------
      subroutine volume_mean(ff,i_name)
      include 'SIZE'
      include 'TOTAL'

      real ff(lx1,ly1,lz1,lelt)
      real work1
      real vol, vol_check, mean_val1, mean_val2, mean_val3, mean_val4
      integer e

      call rzero(mean_val1,1)
      call rzero(mean_val2,1)
      call rzero(mean_val3,1)
      call rzero(mean_val4,1)
      call rzero(vol_check,1)
      call rzero(work1,1)

!-----Volume for aspect ratio=1
      vol=atan(1.0)
      do e=1,nelv
      do k=1,nz1
      do j=1,ny1
      do i=1,nx1
         vol_check=vol_check + bm1(i,j,k,e)
         mean_val1=mean_val1 + ff(i,j,k,e)*bm1(i,j,k,e)
         mean_val2=mean_val2 + (ff(i,j,k,e)**2)*bm1(i,j,k,e)
         mean_val3=mean_val3 + (ff(i,j,k,e)**3)*bm1(i,j,k,e)
         mean_val4=mean_val4 + (ff(i,j,k,e)**4)*bm1(i,j,k,e)
      enddo
      enddo
      enddo
      enddo

!-----Normalization
      mean_val1=mean_val1/vol
      mean_val2=mean_val2/vol
      mean_val3=mean_val3/vol
      mean_val4=mean_val4/vol

!-----Gather over all processes (-> mpi_allreduce)
      call gop(mean_val1,work1,'+  ',1)
      call gop(mean_val2,work1,'+  ',1)
      call gop(mean_val3,work1,'+  ',1)
      call gop(mean_val4,work1,'+  ',1)
      call gop(vol_check,work1,'+  ',1)

!------------------------------------------------------------
      if(nid.eq.0)then

      if(i_name.eq.1)OPEN(10,file="mean_epst.dat",position="append")
      if(i_name.eq.2)OPEN(10,file="mean_epsv.dat",position="append")
      if(i_name.eq.3)OPEN(10,file="mean_uzte.dat",position="append")
      write(10,*)mean_val1,mean_val2,mean_val3,mean_val4,vol_check,vol
      CLOSE(10)

      endif

      return
      end
c-----------------------------------------------------------------------
      subroutine bulk_mean(ff,i_name)
      include 'SIZE'
      include 'TOTAL'

      real ff(lx1,ly1,lz1,lelt)
      real work1
      real vol, vol_check, mean_val1, mean_val2, mean_val3, mean_val4
      integer e
      real height1, height2, radius, radiusc

      call rzero(mean_val1,1)
      call rzero(mean_val2,1)
      call rzero(mean_val3,1)
      call rzero(mean_val4,1)
      call rzero(vol_check,1)
      call rzero(work1,1)

      radiusc=0.3
      height1=0.2
      height2=0.8
      vol=4*atan(1.0)*radiusc**2*(height2-height1)

      do e=1,nelv
      do k=1,nz1
      do j=1,ny1
      do i=1,nx1
         radius=sqrt(xm1(i,j,k,e)**2+ym1(i,j,k,e)**2)
         if (radius.le.radiusc) then
            if (zm1(i,j,k,e).ge.height1 .and.
     $          zm1(i,j,k,e).le.height2) then
                   vol_check=vol_check + bm1(i,j,k,e)
	           mean_val1=mean_val1 + ff(i,j,k,e)*bm1(i,j,k,e)
	           mean_val2=mean_val2 + (ff(i,j,k,e)**2)*bm1(i,j,k,e)
	           mean_val3=mean_val3 + (ff(i,j,k,e)**3)*bm1(i,j,k,e)
	           mean_val4=mean_val4 + (ff(i,j,k,e)**4)*bm1(i,j,k,e)
	    endif
         endif
      enddo
      enddo
      enddo
      enddo

      mean_val1=mean_val1/vol
      mean_val2=mean_val2/vol
      mean_val3=mean_val3/vol
      mean_val4=mean_val4/vol

      call gop(mean_val1,work1,'+  ',1)
      call gop(mean_val2,work1,'+  ',1)
      call gop(mean_val3,work1,'+  ',1)
      call gop(mean_val4,work1,'+  ',1)
      call gop(vol_check,work1,'+  ',1)

      if(nid.eq.0)then
        if(i_name.eq.1)OPEN(10,file="mean_epst_b.dat",position="append")
        if(i_name.eq.2)OPEN(10,file="mean_epsv_b.dat",position="append")
        if(i_name.eq.3)OPEN(10,file="mean_uzte_b.dat",position="append")
        write(10,*)mean_val1,mean_val2,mean_val3,mean_val4,vol_check,vol
        CLOSE(10)
      endif

      return
      end
c-----------------------------------------------------------------------
      subroutine nusselt
      include 'SIZE'
      include 'TOTAL'

      parameter (lt=lx1*ly1*lz1*lelt)
      real dtdx(lt),dtdy(lt),dtdz(lt),w(lt)

      common /chkcmnr/ atime,timel,flux(2)
      common /chkcmni/ iesurf(0:2*lelt,2),ifsurf(0:2*lelt,2)

      integer icalld
      save    icalld
      data    icalld  /0/

      if (icalld.eq.0) then
         icalld = icalld + 1
         atime  = 0.
         timel  = time
         call find_srf(iesurf(0,1),ifsurf(0,1),5)    ! bottom face
         call find_srf(iesurf(0,2),ifsurf(0,2),6)    ! top    face
      endif

!-----Compute temperature gradients for surface fluxes
      call gradm1(dtdx,dtdy,dtdz,t)
      do k = 1,2
         flux(k)  = 0.0
         do isurf = 1,iesurf(0,k)
            ie    = iesurf(isurf,k)
            iface = ifsurf(isurf,k)
            if (CBC(IFACE,IE,1) .NE .'E  ') then
               call surface_flux(dq,dtdx,dtdy,dtdz,ie,iface,w)
               flux(k)  = flux(k)  + dq
            end if
         enddo
      enddo
      call gop(flux,w,'+  ',2)

!-----Output of Nusselt number at top/bottom plate
      dtime = time  - timel
      atime = atime + dtime
      pi4=atan(1.0)
      if (nid.eq.0) then
        write(6,1) istep,time,atime,flux(1)/pi4,-flux(2)/pi4
      endif
    1 format(i6,' Nusselt',1p4e14.6)

      timel = time

      return
      end
c-----------------------------------------------------------------------
      subroutine find_srf(iesurf,ifsurf,inface)
c
c     Find list of surfaces over which the flux should be computed
c     Number of such surfaces is returned in iesurf(0).
c
      include 'SIZE'
      include 'TOTAL'

      integer iesurf(0:lelt),ifsurf(0:lelt)

      nsurf = 0
      nfaces = 2*ndim
      do ie=1,nelv
         nsurf         = nsurf+1
         iesurf(nsurf) = ie
         ifsurf(nsurf) = inface
      enddo
      iesurf(0) = nsurf
      ifsurf(0) = nsurf
      return
      end
c-----------------------------------------------------------------------


PROGRAM timestepper_test

USE omp_lib, only : OMP_SET_NUM_THREADS
USE timestepper, only : Euler, Rk3Ssp, InitializeTimestepper, FinalizeTimestepper

IMPLICIT NONE

INCLUDE 'mpif.h'

DOUBLE PRECISION, PARAMETER :: pi = 3.1415926535897932_8 ! underscore indicates rounding to real(8) precision

DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:,:) :: Q, Qref
DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: err_v, dt_v, convrate

DOUBLE PRECISION :: dt, dx, dy, dz, x, y, z, T0, T1, Tend
INTEGER :: Nx, Ny, Nz, i, j, k, Nsteps, order_adv, nt, &
    mpi_thread_provided, ierr, method, kk, oodt, order_diff

! Too many threads will slow down this test significantly
INTEGER, PARAMETER :: Nthreads = 2

INTEGER, DIMENSION(7) :: N_v = (/ 260, 270, 280, 290, 300, 310, 620 /)

CALL MPI_INIT_THREAD(MPI_THREAD_FUNNELED, mpi_thread_provided, ierr)

CALL OMP_SET_NUM_THREADS(Nthreads)
Tend     = 0.2

DO method = 1,3,2

    IF (method==1) THEN
        order_adv  = 1
        order_diff = 2
    ELSE
        order_adv  = 5
        order_diff = 4
    END IF

    ALLOCATE(err_v(1:SIZE(N_v)-1))
    ALLOCATE(dt_v(1:SIZE(N_v)-1))
    ALLOCATE(convrate(1:SIZE(N_v)-2))

    Nx = 50
    Ny = 51
    Nz = 52

    dy = 1.0/DBLE(Ny)
    dz = 1.0/DBLE(Nz)
    dx = 1.0/DBLE(Nx)

    ALLOCATE(Q(   -2:Nx+3, -2:Ny+3, -2:Nz+3, 0:Nthreads-1))
    ALLOCATE(Qref(-2:Nx+3, -2:Ny+3, -2:Nz+3, 0:Nthreads-1))

    CALL InitializeTimestepper(0.5*dz, Nx, Ny, Nz, Nthreads)

    DO kk=SIZE(N_v),1,-1

        oodt = N_v(kk)

        dt     = 1.0/DBLE(oodt)
        Nsteps = NINT(Tend/dt)
        dt     = Tend/DBLE(Nsteps)

        ! Reset Q
        DO k=1,Nz
            DO j=1,Ny
                DO i=1,Nx

                    x = 0.5*dx + DBLE(i - 1)*dx
                    y = 0.5*dy + DBLE(j - 1)*dy
                    z = 0.5*dz + DBLE(k - 1)*dz

                    Q(i,j,k,:) = SIN(2.0*pi*x)*SIN(2.0*pi*y)*SIN(2.0*pi*z)

                END DO
            END DO
        END DO

        T0 = MPI_WTIME()
        !$OMP PARALLEL DO schedule(static)
        DO nt=0,Nthreads-1
            IF (method==1) THEN
                CALL Euler(Q(:,:,:,nt), DBLE(0.0), Tend, Nsteps, dx, dy, dz, order_adv, order_diff)

            ELSE IF (method==3) THEN
                CALL Rk3Ssp(Q(:,:,:,nt), DBLE(0.0), Tend, Nsteps, dx, dy, dz, order_adv, order_diff)
            ELSE
                WRITE(*,*) 'Method can only have values 1 and 3. Now exiting...'
                STOP
            END IF
        END DO
        !$OMP END PARALLEL DO
        T1 = MPI_WTIME()

        DO nt=1,Nthreads-1
            IF (MAXVAL(ABS(Q(:,:,:,nt)-Q(:,:,:,nt-1)))>1e-14) THEN
                WRITE(*,'(A, I1, A)') 'ERROR: For method=', method, ' not all threads computed the same result, this should not have happened. Now exiting...'
                STOP
            END IF
        END DO

        IF (ANY(ISNAN(Q))) THEN
            WRITE(*,'(A, I1, A)') 'ERROR: For method=', method, ' found NAN in solution, run is probably unstable. Now exiting...'
            STOP
        END IF
        ! For nonlinear advection, no analytic solution is available to use solution
        ! with finest time-step as reference
        IF (kk==SIZE(N_v)) THEN
            Qref = Q
        ELSE
            dt_v(kk)  = dt
            err_v(kk) = MAXVAL(ABS(Q(1:Nx,1:Ny,1:Nz,:) - Qref(1:Nx,1:Ny,1:Nz,:)))
            !WRITE(*,'(E9.3)') err_v(kk)
        END IF

    END DO ! N_v

    DO kk=1,SIZE(N_v)-2
        convrate(kk) = LOG10( err_v(kk+1)/err_v(kk) )/LOG10( dt_v(kk+1)/dt_v(kk) )
    END DO

    IF (MINVAL(convrate)<=0.95*method) THEN
        WRITE(*,'(A, I1, A, I1)') 'ERROR: Failed to verify convergence order for method = ', method, ', order = ', order_adv
        DO kk=1,SIZE(N_v)-2
           WRITE(*,'(F6.3)') convrate(kk)
        END DO
        STOP
    END IF

    CALL FinalizeTimestepper

    DEALLOCATE(Q)
    DEALLOCATE(Qref)
    DEALLOCATE(err_v)
    DEALLOCATE(dt_v)
    DEALLOCATE(convrate)

END DO ! method

CALL MPI_FINALIZE(ierr)

PRINT*, '\x1B[32m[0] -- Successful: Timestepping methods produced expected order of convergence.\x1B[0m'

END PROGRAM timestepper_test


    real :: a(7), b(7), c(7)
!   a = sign(b,c) + min(abs(b), abs(c))
!   a = min(abs(b), abs(c))
!   a = abs(abs(c))
!   a = abs(c) + abs(b)
    a = abs(c)
    a = abs(b)
end


module M_test_suite_M_random
use M_msg
use M_verify, only : unit_check_start,unit_check,unit_check_done,unit_check_good,unit_check_bad,unit_check_msg, unit_check_level
use M_random
private
public test_suite
contains
subroutine test_suite()

!*! setup

   call test_init_random_seed()
   call test_init_random_seed_by_dat()
   call test_init_random_seed_by_system_clock()

   call test_random_kiss64()

   call test_random_hex()
   call test_random_string()
   call test_random_int()

   call test_scramble()

   call test_mtprng_init()
   call test_mtprng_init_by_array()
   call test_mtprng_rand()
   call test_mtprng_rand64()
   call test_mtprng_rand_range()
   call test_mtprng_rand_real1()
   call test_mtprng_rand_real2()
   call test_mtprng_rand_real3()

!*! teardown
contains
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_init_random_seed()

integer :: i
real    :: x
intrinsic random_number
   call unit_check_start('init_random_seed',msg='')
   call init_random_seed_by_dat()
   do i=1,10
      ! assigned pseudo-random numbers from the uniform distribution in the interval 0 <= x < 1.
      call random_number(x)
      if(unit_check_level.gt.0)then
         write(*,'(g0,1x)',advance='no')x
      endif
   enddo
   !*!call unit_check('init_random_seed', 0.eq.0, 'checking',100)
   call unit_check_done('init_random_seed',msg='')
end subroutine test_init_random_seed
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_init_random_seed_by_dat()

integer :: i
real    :: x
intrinsic random_number
   call unit_check_start('init_random_seed_by_dat',msg='')
   call init_random_seed_by_dat()
   do i=1,10
      ! assigned pseudo-random numbers from the uniform distribution in the interval 0 <= x < 1.
      call random_number(x)
      if(unit_check_level.gt.0)then
         write(*,'(g0,1x)',advance='no')x
      endif
   enddo
   !*!call unit_check('init_random_seed_by_dat', 0.eq.0, 'checking',100)
   call unit_check_done('init_random_seed_by_dat',msg='')
end subroutine test_init_random_seed_by_dat
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_init_random_seed_by_system_clock()

integer :: i
real    :: x
intrinsic random_number
   call unit_check_start('init_random_seed_by_system_clock',msg='')
   call init_random_seed_by_system_clock()
   do i=1,10
      ! assigned pseudo-random numbers from the uniform distribution in the interval 0 <= x < 1.
      call random_number(x)
      if(unit_check_level.gt.0)then
         write(*,'(g0,1x)',advance='no')x
      endif
   enddo
   !*!call unit_check('init_random_seed_by_system_clock', 0.eq.0, 'checking',100)
   call unit_check_done('init_random_seed_by_system_clock',msg='')
end subroutine test_init_random_seed_by_system_clock
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_mtprng_init()

   call unit_check_start('mtprng_init',msg='')
   !*!call unit_check('mtprng_init', 0.eq.0, 'checking',100)
   call unit_check_done('mtprng_init',msg='')
end subroutine test_mtprng_init
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_mtprng_init_by_array()

   call unit_check_start('mtprng_init_by_array',msg='')
   !*!call unit_check('mtprng_init_by_array', 0.eq.0, 'checking',100)
   call unit_check_done('mtprng_init_by_array',msg='')
end subroutine test_mtprng_init_by_array
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_mtprng_rand()

   call unit_check_start('mtprng_rand',msg='')
   !*!call unit_check('mtprng_rand', 0.eq.0, 'checking',100)
   call unit_check_done('mtprng_rand',msg='')
end subroutine test_mtprng_rand
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_mtprng_rand64()

!use M_random, only : mtprng_state, mtprng_init, mtprng_rand64, mtprng_rand_real1
use, intrinsic :: iso_fortran_env, only : int8, int16, int32, int64  !  1 2 4 8
implicit none

integer(INT32)     :: seed
type(mtprng_state) :: state
integer            :: i, misses
integer(INT64)     :: known(100), hop
double precision   :: known_double
logical            :: success, success_double

known = (/ &
   1062284148_INT64  ,  1840134109_INT64  ,  3636226446_INT64  ,   887288380_INT64  ,  3889928508_INT64  ,  &
    631642018_INT64  ,   914101460_INT64  ,  3162600344_INT64  ,  4279173875_INT64  ,  3888840898_INT64  ,  &
   2663878183_INT64  ,  2252856790_INT64  ,  3463027370_INT64  ,  1097057726_INT64  ,  3184139039_INT64  ,  &
   1434652676_INT64  ,  3403152620_INT64  ,   833869435_INT64  ,   612581734_INT64  ,   576299959_INT64  ,  &
   1474687423_INT64  ,  3466262180_INT64  ,  3133945242_INT64  ,  2677293441_INT64  ,  3505646298_INT64  ,  &
   1339531483_INT64  ,  3669763788_INT64  ,   510452911_INT64  ,   559989931_INT64  ,  2308431220_INT64  ,  &
   3603446463_INT64  ,   667203617_INT64  ,  1127428958_INT64  ,  1290717533_INT64  ,  3513405708_INT64  ,  &
    927031876_INT64  ,  4032539667_INT64  ,  3825851657_INT64  ,  2014122148_INT64  ,  3946341433_INT64  ,  &
   2489727744_INT64  ,  3391425033_INT64  ,  1283015508_INT64  ,   913542342_INT64  ,   764165363_INT64  ,  &
   3945892851_INT64  ,  2442690715_INT64  ,  1067765245_INT64  ,  2537181202_INT64  ,  3064480631_INT64  ,  &
   3101723380_INT64  ,   802526031_INT64  ,  3157511722_INT64  ,  3269291235_INT64  ,  4215855479_INT64  ,  &
    181260300_INT64  ,  3744061959_INT64  ,  1143883471_INT64  ,    53781702_INT64  ,   882249490_INT64  ,  &
    321985400_INT64  ,   577208133_INT64  ,   885895688_INT64  ,  2725767908_INT64  ,  2231810848_INT64  ,  &
   1980748708_INT64  ,  3886306640_INT64  ,   202325230_INT64  ,  3043114780_INT64  ,  2021505937_INT64  ,  &
   1074135674_INT64  ,   753749191_INT64  ,  3155169167_INT64  ,  2997245061_INT64  ,  1203929572_INT64  ,  &
   2247630318_INT64  ,  1571401504_INT64  ,  4114645852_INT64  ,  3048726454_INT64  ,  3912566191_INT64  ,  &
    546592897_INT64  ,  3352654755_INT64  ,  3632644786_INT64  ,  3691031383_INT64  ,  1267283456_INT64  ,  &
    900236841_INT64  ,    47733538_INT64  ,  2049551875_INT64  ,   668453652_INT64  ,  2379406100_INT64  ,  &
    689049113_INT64  ,   759943852_INT64  ,   623176051_INT64  ,  1348915232_INT64  ,  1345348561_INT64  ,  &
   2055844659_INT64  ,  3678167085_INT64  ,  1856143658_INT64  ,  2464849813_INT64  ,    28304277_INT64    /)

  known_double = 0.96673825731657869742d0
  seed = 6928

  call unit_check_start('mtprng_rand64',msg='')
  call mtprng_init(seed, state)

  misses = 0
  success=.true.
  do i=1,100
     hop = mtprng_rand64(state)
     if (hop.ne.known(i)) misses=misses+1
  enddo
  if (misses>0) success=.false.

! retourne un reel IEEE64, peut  tre utilis  en double precision
  if ( abs(mtprng_rand_real1(state)-known_double) > 5d-16 ) then
     success_double = .false.
  else
     success_double = .true.
  endif

  call unit_check('mtprng_rand64', success,        'integer misses',misses)
  call unit_check('mtprng_rand64', success_double, 'double precision')

  call unit_check_done('mtprng_rand64',msg='')
end subroutine test_mtprng_rand64
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_mtprng_rand_range()

   call unit_check_start('mtprng_rand_range',msg='')
   !*!call unit_check('mtprng_rand_range', 0.eq.0, 'checking',100)
   call unit_check_done('mtprng_rand_range',msg='')
end subroutine test_mtprng_rand_range
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_mtprng_rand_real1()

   call unit_check_start('mtprng_rand_real1',msg='')
   !*!call unit_check('mtprng_rand_real1', 0.eq.0, 'checking',100)
   call unit_check_done('mtprng_rand_real1',msg='')
end subroutine test_mtprng_rand_real1
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_mtprng_rand_real2()

   call unit_check_start('mtprng_rand_real2',msg='')
   !*!call unit_check('mtprng_rand_real2', 0.eq.0, 'checking',100)
   call unit_check_done('mtprng_rand_real2',msg='')
end subroutine test_mtprng_rand_real2
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_mtprng_rand_real3()

   call unit_check_start('mtprng_rand_real3',msg='')
   !*!call unit_check('mtprng_rand_real3', 0.eq.0, 'checking',100)
   call unit_check_done('mtprng_rand_real3',msg='')
end subroutine test_mtprng_rand_real3
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_random_int()

   call unit_check_start('random_int',msg='')
   !*!call unit_check('random_int', 0.eq.0, 'checking',100)
   call unit_check_done('random_int',msg='')
end subroutine test_random_int
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_random_hex()

integer :: i
real    :: x
intrinsic random_number
   call unit_check_start('random_hex',msg='')
   call init_random_seed(218595421)
   do i=1,2
      write(*,*)random_hex(32)
      write(*,*)random_hex(64)
      write(*,*)random_hex(128)
      write(*,*)random_hex(256)
      write(*,*)random_hex(512)
   enddo
   !*!call unit_check('random_hex', 0.eq.0, 'checking',100)
   call unit_check_done('random_hex',msg='')
end subroutine test_random_hex
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_random_kiss64()

integer, parameter    :: i8b = selected_int_kind(18)  ! eight-byte integer
integer(i8b)          :: i, t
   call unit_check_start('random_kiss64',msg='')
   do i = 1, 100000000
      t = random_kiss64()
      if(unit_check_level.gt.0)then
         if(mod(i,1000000_i8b+1_i8b)==1000000_i8b)write(*,*)i,' T=',T
      endif
   enddo
 !*!call unit_check('random_kiss64',t.eq.1666297717051644203_i8b,'100 million calls to KILL',t,16662977170511644203_i8b)
   call unit_check('random_kiss64',t.eq.1666297717051644203_i8b,msg='100 million calls to KILL')
   call unit_check_done('random_kiss64',msg='')
end subroutine test_random_kiss64
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_scramble()

   call unit_check_start('scramble',msg='')
   !*!call unit_check('scramble', 0.eq.0, 'checking',100)
   call unit_check_done('scramble',msg='')
end subroutine test_scramble
!TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTT
subroutine test_random_string()

intrinsic random_number
integer           :: i
real              :: x
integer,parameter :: tests=100
character(len=8)  :: alpha(tests)
integer           :: repeats
   repeats=0
   call unit_check_start('random_string',msg='')
   call init_random_seed(218595421)
   do i=1,tests
      alpha(i)=random_string('ABCDEFGHIJKLMNOPQRSTUVWXYZ',8)
   enddo
   do i=1,tests
   if(.not.random_string('ABCDEFGHIJKLMNOPQRSTUVWXYZ',8).eq.alpha(i))then
      repeats=repeats+1
   endif
   enddo
   call unit_check('random_string', repeats.eq.tests,'test if repeats with same seed',tests)
   call unit_check_done('random_string',msg='')
end subroutine test_random_string
!===================================================================================================================================
end subroutine test_suite
!==================================================================================================================================!
end module M_test_suite_M_random
!==================================================================================================================================!
program runtest
use M_msg
use M_verify, only : unit_check_command, unit_check_keep_going, unit_check_level, unit_check_stop
use M_test_suite_M_random
implicit none
   unit_check_command=''
   unit_check_keep_going=.true.
   unit_check_level=0
   call test_suite()
   call unit_check_stop()
end program runtest
!==================================================================================================================================!


#SET<sort><quick_sort_flat>#
!> @ingroup #<sort><name>##ord#
!>
!> @brief
!> Run #<sort><docRef># on a vector of #<data><full># values.
!>
!> @details
!> Run #<ord><docRef># on a vector of #<data><full># values to sort them in the specified order.#IF<map><true>THEN<The vector of intergers map is permuted in the same way that the vector #<data><var># is permuted to be sorted. It is important that #<map><var># be at least as long as #<data><var>#.>ENDIF#
!>
!> @param #<data><var>#
!> The vector #<data><full># values to be sorted.
!>
#IF<map><true>#!> @param #<map><var>#
#IF<map><true>#!> Vector of intergers which is permuted in the same way that #<data><var># is permuted. If #<map><var># is a vector of values 1 to N, where N is the length of #<data><var>#, than, #<map><var># is the map from #<data><var>#'s original value to #<data><var>#'s final value after the sort.
#IF<map><true>#!>
#IF<ord><gen>#!> @param #<ord><var>#
#IF<ord><gen>#!> A logical function which describes the ordering used. The function must take two #<data><full># arguments and return true if and only if the first argument must proceed the second argument in the order.
#IF<ord><gen>#!>
!> @note
!> This flat quick sort works by maintaning a psudo stack.  As the the subroutine runs vec splices of vec are broken into two groups based on comparison to a pivot chosen based on the average value of the first and last element of of the slice.  The same process is then applied to the larger of the two slices.  After a slice is sorted the next smallest slice of vec is sorted.
!>
!> Example ignoring the interchange sort     4 3 7 9 1 2
!> i    pivot    lower     upper
!> 1    3        1         6                |2 1 7 9 3 4|
!> 2    5        3         6                 2 1|4 3 9 7]
!> 3    8        5         6                 2 1 4 3|7 9|
!> 2    4        3         4                 2 1|3 4|7 9
!> 1    1        1         2                |1 2|3 4 7 9
!>
!> The alogorithm of the flat quick sort is harder to follow than the more conventional flat quick sort; however, it saves system resoruces.  Also on systems with limitations on stack sizes a flat quick sort allows sorting of larger lists.  The natural limit is the value of the vector levels.  This can cause a failure in some cases.
!>
!> @note
!> Some credit for this implimentation must go to Darel Flex's implimentation that can be found here.
!e
!> @warning
!> Error will occur if max_interchange_sort_size is less than one.
!>>
#IF<ord><gen>#!> @warning
#IF<ord><gen>#!> The argument types and counts of #<ord><var># are not checked within this subroutine.
#IF<ord><gen>#!>
#IF<map><true>#!> @warning
#IF<map><true>#!> The length of #<map><var># is not checked within this subroutine. If the length of #<data><var># is larger than the length of #<map><var>#, than this subroutine may attempt to access elements outside of #<map><var>#.
#IF<map><true>#!>
!> @author Arin R. Bratt
!> @date 11/07/2014
#IF<ord><gen>THEN<>ELSE<pure >ENDIF#subroutine #<sort><name>##ord##map##data#(#<data><var>##<map><arg>##<ord><arg>#)
  ! Arguments
  #<data><full>#, intent(inout) :: #<data><var>#(:)
  #IF<map><true>#integer, intent(inout) :: #<map><var>#(:)
  #IF<ord><gen>#procedure(logical) :: #<ord><var>#

  ! Parameters
  integer, parameter :: stack_levels = 300

  ! Variables
  integer :: idx
  integer :: low
  integer :: high
  integer :: lower(stack_levels)
  integer :: upper(stack_levels)
  #<data><full># :: pivot
  #<data><full># :: #<data><swap>#

  ! Initilize the stack
  idx = 1
  lower(idx) = 1
  upper(idx) = #SIZE# + 1

  ! Main loop
  do while(idx >= 1)
     ! Sort the slice of #<data><var># between lower(idx) and upper(idx)
     low = lower(idx)
     high = upper(idx) - 1

     if (low < high) then
        pivot = (#<data><var>#(high) + #<data><var>#(low)) / 2
        do while(low < high)

           if (high - low < max_interchange_sort_size) then
              ! Run interchange sort on small vectors
              if (low < high) call interchange_sort#ord##map##data#(#<data><var>#(low:high)#IF<map><true>THEN<,#<map><var>#(low:high)>ENDIF##<ord><arg>#)
              idx = idx - 1
           else
              ! Run quick sort on large vectors
              ! This pivot helps avoid n^2 behavior, expect in expontially growning and shrinking (reverse) sorted lists and lists of indentical elements.
              pivot = (#<data><var>#(high) + #<data><var>#(low)) / 2
              do
                 ! This loop finds elements on the wrong side of the pivot and swaps until no such elements are left.
                 ! Consider running these in parallel

                 ! Find the first element below the pivot that must be above the pivot.
                 do while(low <= high)
                    if (#ORD<#<data><var>#(low)><pivot>#) exit
                    low = low + 1
                 end do

                 ! Find the first element above the pivot that must be below the pivot.
                 do while (high > lower(idx))
                    if (#ORD<pivot><#<data><var>#(high)>#) exit
                    high = high - 1
                 end do

                 if (high > low) then
                    !If #<data><var>#(low) must follow #<data><var>#(high) than swap their values.
                    #SWAP<#<data><var>#(low)><#<data><var>#(high)>#
                    low = low + 1
                    high = high - 1
                 else
                    ! If #<data><var>#(low) does not have to follow #<data><var>#(high) than exit.
                    ! There may be a way to rewrite to remove this if.
                    if (low == upper(idx)) then
                       high = low
                       low = low - 1
                    else
                       high = low + 1
                    end if
                    exit
                 end if
              end do

              ! Split splice based on pivot, making sure to throw the smaller splice on the higher end of the stack
              if (upper(idx) - high < low - lower(idx)) then
                 upper(idx + 1) = upper(idx)
                 lower(idx + 1) = high
                 upper(idx) = low
              else
                 upper(idx + 1) = low
                 lower(idx + 1) = lower(idx)
                 lower(idx) = high
              end if
              idx = idx + 1
           end if
        end do
     end if
  end do
end subroutine #<sort><name>##ord##map##data#


!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_FUNC_DS

    USE MR_KINDS

    USE MR_DEF_CONSTS_N_REF_PARS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_FUNC_DS

    INTERFACE MR_FUNC_DS
      MODULE PROCEDURE MR_FUNC_DS_PARD_KIND
      MODULE PROCEDURE MR_FUNC_DS_FDRD_KIND
    END INTERFACE

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

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_FUNC_DS_PARD_KIND( D0 ) RESULT( DS )

    IMPLICIT NONE

    REAL(PARD_KIND) , INTENT(IN ) :: D0

    REAL(PARD_KIND) :: DS

    DS = D0 / ( DSPAR * ZR )

  END FUNCTION MR_FUNC_DS_PARD_KIND

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  FUNCTION MR_FUNC_DS_FDRD_KIND( D0 ) RESULT( DS )

    IMPLICIT NONE

    REAL(FDRD_KIND) , INTENT(IN ) :: D0

    REAL(FDRD_KIND) :: DS

    DS = D0 / ( DSPAR * ZR )

  END FUNCTION MR_FUNC_DS_FDRD_KIND

  END MODULE MR_MOD_FUNC_DS


      PROGRAM xbessjy
C     driver for routine bessjy
      INTEGER i,nval
      REAL rj,ry,rjp,ryp,x,xnu,xrj,xry,xrjp,xryp
      CHARACTER text*25
      open(7,file='FNCVAL.DAT',status='OLD')
10    read(7,'(a)') text
      if (text.ne.'Ordinary Bessel Functions') goto 10
      read(7,*) nval
      write(*,*) text
      write(*,'(1x,t3,a3,t8,a1)') 'XNU','X'
      write(*,'(1x,t5,a2,t21,a2,t37,a3,t53,a3)') 'RJ','RY','RJP','RYP'
      write(*,'(1x,t5,a3,t21,a3,t37,a4,t53,a4)')
     *     'XRJ','XRY','XRJP','XRYP'
      do 11 i=1,nval
        read(7,*) xnu,x,rj,ry,rjp,ryp
        call bessjy(x,xnu,xrj,xry,xrjp,xryp)
        write(*,'(2f6.2/1p4e16.6/1p4e16.6)')
     *       xnu,x,rj,ry,rjp,ryp,xrj,xry,xrjp,xryp
11    continue
      close(7)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xbessjy.for


      PROGRAM xhpsel
C     driver for routine hpsel
      INTEGER NP
      PARAMETER(NP=100)
      REAL arr(NP),heap(NP)
      INTEGER i,k
      REAL check,select
      open(7,file='TARRAY.DAT',status='OLD')
      read(7,*) (arr(i),i=1,NP)
      close(7)
1     write(*,*) 'enter K'
      read(*,*,END=999) k
      call hpsel(k,NP,arr,heap)
      check=select(NP+1-k,NP,arr)
      write(*,*) 'heap(1),check=',heap(1),check
      write(*,*) 'heap of numbers of size',k
      do 11 i=1,k
        write(*,*) i,heap(i)
11    continue
      goto 1
999   write(*,*) 'NORMAL COMPLETION'
      STOP
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xhpsel.for