      SUBROUTINE PSSVDTST( M, N, NPROW, NPCOL, NB, ISEED, THRESH, WORK,
     $                     RESULT, LWORK, NOUT )
*
*  -- ScaLAPACK routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      INTEGER            LWORK, M, N, NB, NOUT, NPCOL, NPROW
      REAL               THRESH
*     ..
*     .. Array Arguments ..
      INTEGER            ISEED( 4 ), RESULT( 9 )
      REAL               WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  PSSVDTST checks the singular value decomposition (SVD) routine
*  PSGESVD. PSGESVD factors A = U diag(S) VT, where U and VT are
*  orthogonal and diag(S) is diagonal with the entries of the array
*  S on its diagonal. The entries of S are the singular values, stored
*  in decreasing order. U and VT can be optionally not computed,
*  computed and overwritten on A, or computed partially.
*
*  A is M by N. Let SIZE = min( M, N ). S has dimension SIZE by SIZE.
*  U is M by SIZE and VT is SIZE by  N. PDGESVD optionally calculates
*  U and VT, depending on the values of its parameters JOBU and JOBVT.
*  There are four possible  combinations of "job" parameters for a call
*  to PDGESVD, that correspond to four values of internal index JOBTYPE.
*  The table below shows the mapping between "job" parameters of
*  PDGESVD and respective values of the index JOBTYPE together
*  with matrices computed for each type of the job.
*
*
*              |   JOBU = 'V'     |       JOBU = 'N'
*   ---------- -------------------------------------------
*   JOBVT = 'V'|  JOBTYPE = 1     |   JOBTYPE = 3
*              |  U1, S1, VT1     |   S3, VT3
*   ---------- ------------------------------------------
*   JOBVT = 'N'|  JOBTYPE = 2     |   JOBTYPE = 4
*              |  U2, S2          |   S4
*
*
*  When PSSVDTST is called, a number of matrix "types" are specified.
*  For each type of matrix, and for the minimal workspace as well as
*  for larger than minimal workspace an M x N matrix "A" with known
*  singular values is generated and used to test the SVD routines.
*  For each matrix, A will be factored as A = U diag(S) VT and the
*  following 9 tests computed:
*
*  (1)   | A - U1 diag(S1) VT1 | / ( |A| max(M,N) ulp )
*
*  (2)   | I - U1'U1 | / ( M ulp )
*
*  (3)   | I - VT1 VT1' | / ( N ulp ),
*
*  (4)   S1 contains SIZE  nonnegative values in decreasing order.
*        (Return 0 if true, 1/ULP if false.)
*
*  (5)   | S1 - S2 | / ( SIZE ulp |S| )
*
*  (6)   | U1 - U2 | / ( M ulp )
*
*  (7)   | S1 - S3 | / ( SIZE ulp |S| )
*
*  (8)   | VT1 - VT3 | / ( N ulp )
*
*  (9)   | S1 - S4 | / (  SIZE ulp |S| )
*
*  Currently, the list of possible  matrix types is:
*
*  (1)  The zero matrix.
*
*  (2)  The identity matrix.
*
*  (3)  A diagonal matrix with evenly spaced entries
*       1, ..., ULP.
*       (ULP = (first number larger than 1) - 1 )
*
*  (4)  A matrix of the form  U D VT, where U, VT are orthogonal and
*       D has evenly spaced entries 1, ..., ULP.
*
*  (5) Same as (4), but multiplied by SQRT( overflow threshold )
*
*  (6) Same as (4), but multiplied by SQRT( underflow threshold )
*
*
*  Notes
*  =====
*
*  Each global data object is described by an associated description
*  vector.  This vector stores the information required to establish
*  the mapping between an object element and its corresponding process
*  and memory location.
*
*  Let A be a generic term for any 2D block cyclicly distributed array.
*  Such a global array has an associated description vector DESCA.
*  In the following comments, the character _ should be read as
*  "of the global array".
*
*  NOTATION        STORED IN      EXPLANATION
*  --------------- -------------- --------------------------------------
*  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
*                                 DTYPE_A = 1.
*  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
*                                 the BLACS process grid A is distribu-
*                                 ted over. The context itself is glo-
*                                 bal, but the handle (the integer
*                                 value) may vary.
*  M_A    (global) DESCA( M_ )    The number of rows in the global
*                                 array A.
*  N_A    (global) DESCA( N_ )    The number of columns in the global
*                                 array A.
*  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
*                                 the rows of the array.
*  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
*                                 the columns of the array.
*  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
*                                 row of the array A is distributed.
*  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
*                                 first column of the array A is
*                                 distributed.
*  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
*                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
*
*  Let K be the number of rows or columns of a distributed matrix,
*  and assume that its process grid has dimension p x q.
*  LOCr( K ) denotes the number of elements of K that a process
*  would receive if K were distributed over the p processes of its
*  process column.
*  Similarly, LOCc( K ) denotes the number of elements of K that a
*  process would receive if K were distributed over the q processes of
*  its process row.
*  The values of LOCr() and LOCc() may be determined via a call to the
*  ScaLAPACK tool function, NUMROC:
*          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
*          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
*  An upper bound for these quantities may be computed by:
*          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
*          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
*
*  Arguments
*  ==========
*
*  M      (global input) INTEGER dimension
*         The value of the matrix row dimension.
*
*  N      (global input) INTEGER dimension
*         The value of the matrix column dimension.
*
*  NPROW  (global input) INTEGER
*         Number of process rows
*
*  NPCOL  (global input) INTEGER
*         Number of process columns
*
*  NB     (global input) INTEGER
*         The block size of the matrix A. NB >=1.
*
*  ISEED  (global input/local output) INTEGER array, dimension (4)
*         On entry, the seed of the random number generator.  The array
*         elements should be between 0 and 4095; if not they will be
*         reduced mod 4096.  Also, ISEED(4) must be odd.
*         On exit, ISEED is changed and can be used in the next call to
*         SDRVBD to continue the same random number sequence.
*
*  THRESH (global input) REAL
*         The threshold value for the test ratios.  A result is
*         included in the output file if RESULT >= THRESH.  The test
*         ratios are scaled to be O(1), so THRESH should be a small
*         multiple of 1, e.g., 10 or 100.  To have every test ratio
*         printed, use THRESH = 0.
*
*  RESULT (global input/output) INTEGER array of dimension 9. Initially
*         RESULT( I ) = 0. On the output, RESULT ( I ) = 1 if test I
*         ( see above ) wasn't passed.
*
*  WORK   (local workspace) REAL array, dimension (LWORK)
*
*  LWORK  (local input) INTEGER
*         Dimension of the array WORK. It is defined as follows
*         LWORK = 1 + 2*LDA*NQ + 3*SIZE +
*         MAX(WPSLAGGE, LDU*SIZEQ + LDVT*NQ + MAX(LDU*SIZEQ, LDVT*NQ)
*         + WPSGESVD + MAX( WPSSVDCHK, WPSSVDCMP)),
*         where WPSLAGGE, WPSGESVD, WPSSVDCHK,  WPSSVDCMP are amounts
*         of workspace required respectively by PSLAGGE, PSGESVD,
*         PSSVDCHK, PSSVDCMP.
*         Here
*         LDA = NUMROC( M, NB, MYROW, 0, NPROW ), LDU = LDA,
*         LDVT = NUMROC( SIZE, NB, MYROW, 0, NPROW ),
*         NQ = NUMROC( N, NB, MYCOL, 0, NPCOL ),
*         SIZEQ = NUMROC( SIZE, NB, MYCOL, 0, NPCOL ).
*         Values of the variables WPSLAGGE, WPSGESVD, WPSSVDCHK,
*         WPSSVDCMP are found by "dummy" calls to
*         the respective routines. In every "dummy" call, variable
*         LWORK is set to -1, thus causing respective routine
*         immediately return required workspace in WORK(1) without
*         executing any calculations
*
*  NOUT   (local input) INTEGER
*         The unit number for output file.  Only used on node 0.
*         NOUT = 6, output to screen,
*         NOUT = 0, output to stderr.
*  =====================================================================
*
*     .. Parameters ..
      INTEGER             BLOCK_CYCLIC_2D, DLEN_, DTYPE_, CTXT_, M_, N_,
     $                    MB_, NB_, RSRC_, CSRC_, LLD_, NTYPES
      PARAMETER           ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
     $                    CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
     $                    RSRC_ = 7, CSRC_ = 8, LLD_ = 9, NTYPES = 6 )
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
*     ..
*     .. Local Scalars ..
      CHARACTER          HETERO, JOBU, JOBVT
      INTEGER            CONTEXT, DINFO, I, IA, IAM, INFO, ITYPE, IU,
     $                   IVT, JA, JOBTYPE, JU, JVT, LDA, LDU, LDVT,
     $                   LLWORK, LWMIN, MYCOL, MYROW, NNODES, NQ, PASS,
     $                   PTRA, PTRAC, PTRD, PTRS, PTRSC, PTRU, PTRUC,
     $                   PTRVT, PTRVTC, PTRWORK, SETHET, SIZE, SIZEQ,
     $                   WPSGESVD, WPSLAGGE, WPSSVDCHK, WPSSVDCMP
      REAL               CHK, DELTA, H, MTM, OVFL, RTOVFL, RTUNFL, ULP,
     $                   UNFL
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_BARRIER, BLACS_GET, BLACS_GRIDEXIT,
     $                   BLACS_GRIDINFO, BLACS_GRIDINIT, BLACS_PINFO,
     $                   BLACS_SET,
     $                   DESCINIT, SGAMN2D, SGAMX2D, SLABAD, SSCAL,
     $                   IGAMN2D, IGAMX2D, IGEBR2D, IGEBS2D, PSELSET,
     $                   PSGESVD, PSLACPY, PSLAGGE, PSLASET, PSSVDCHK,
     $                   PSSVDCMP, PXERBLA, SLBOOT, SLCOMBINE, SLTIMER
*     ..
*     .. External Functions ..
      INTEGER            NUMROC
      REAL               PSLAMCH
      EXTERNAL           NUMROC, PSLAMCH
*     ..
*     .. Local Arrays ..
      INTEGER            DESCA( DLEN_ ), DESCU( DLEN_ ),
     $                   DESCVT( DLEN_ ), ITMP( 2 )
      DOUBLE PRECISION   CTIME( 1 ), WTIME( 1 )
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, INT, MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*     This is just to keep ftnchek happy
      IF( BLOCK_CYCLIC_2D*CSRC_*DTYPE_*LLD_*MB_*M_*NB_*N_*RSRC_.LT.0 )
     $   RETURN
*
      CALL BLACS_PINFO( IAM, NNODES )
      CALL BLACS_GET( -1, 0, CONTEXT )
      CALL BLACS_GRIDINIT( CONTEXT, 'R', NPROW, NPCOL )
      CALL BLACS_GRIDINFO( CONTEXT, NPROW, NPCOL, MYROW, MYCOL )
*
*     If this process is not a part of the contex, bail out now.
*
      IF( ( MYROW.GE.NPROW ) .OR. ( MYROW.LT.0 ) .OR.
     $    ( MYCOL.GE.NPCOL ) .OR. ( MYCOL.LT.0 ) )GO TO 110
      CALL BLACS_SET( CONTEXT, 15, 1 )
      INFO = 0
*
*     Check input parameters.
*
      IF( M.LE.0 ) THEN
         INFO = -1
      ELSE IF( N.LE.0 ) THEN
         INFO = -2
      ELSE IF( NPROW.LE.0 ) THEN
         INFO = -3
      ELSE IF( NPCOL.LE.0 ) THEN
         INFO = -4
      ELSE IF( NB.LE.0 ) THEN
         INFO = -5
      ELSE IF( THRESH.LE.0 ) THEN
         INFO = -7
      END IF
*
      SIZE = MIN( M, N )
*
*     Initialize matrix descriptors.
*
      IA  = 1
      JA  = 1
      IU  = 1
      JU  = 1
      IVT = 1
      JVT = 1
*
      LDA = NUMROC( M, NB, MYROW, 0, NPROW )
      LDA = MAX( 1, LDA )
      NQ = NUMROC( N, NB, MYCOL, 0, NPCOL )
      LDU = LDA
      SIZEQ = NUMROC( SIZE, NB, MYCOL, 0, NPCOL )
      LDVT = NUMROC( SIZE, NB, MYROW, 0, NPROW )
      LDVT = MAX( 1, LDVT )
      CALL DESCINIT( DESCA, M, N, NB, NB, 0, 0, CONTEXT, LDA, DINFO )
      CALL DESCINIT( DESCU, M, SIZE, NB, NB, 0, 0, CONTEXT, LDU, DINFO )
      CALL DESCINIT( DESCVT, SIZE, N, NB, NB, 0, 0, CONTEXT, LDVT,
     $               DINFO )
*
*     Set some pointers to work array in order to do "dummy" calls.
*
      PTRA = 2
      PTRAC = PTRA + LDA*NQ
      PTRD = PTRAC + LDA*NQ
      PTRS = PTRD + SIZE
      PTRSC = PTRS + SIZE
      PTRWORK = PTRSC + SIZE
*
      PTRU = PTRWORK
      PTRVT = PTRWORK
      PTRUC = PTRWORK
      PTRVTC = PTRWORK
*
*     "Dummy" calls -- return required workspace in work(1) without
*     any calculation.
*
      CALL PSLAGGE( M, N, WORK( PTRD ), WORK( PTRA ), IA, JA, DESCA,
     $              ISEED, SIZE, WORK( PTRWORK ), -1, DINFO )
      WPSLAGGE = INT( WORK( PTRWORK ) )
*
      CALL PSGESVD( 'V', 'V', M, N, WORK( PTRA ), IA, JA, DESCA,
     $              WORK( PTRS ), WORK( PTRU ), IU, JU, DESCU,
     $              WORK( PTRVT ), IVT, JVT, DESCVT,
     $              WORK( PTRWORK ), -1, DINFO )
      WPSGESVD = INT( WORK( PTRWORK ) )
*
      CALL PSSVDCHK( M, N, WORK( PTRAC ), IA, JA, DESCA, WORK( PTRUC ),
     $               IU, JU, DESCU, WORK( PTRVT ), IVT, JVT, DESCVT,
     $               WORK( PTRS ), THRESH, WORK( PTRWORK ), -1,
     $               RESULT, CHK, MTM )
      WPSSVDCHK = INT( WORK( PTRWORK ) )
*
      CALL PSSVDCMP( M, N, 1, WORK( PTRS ), WORK( PTRSC ), WORK( PTRU ),
     $               WORK( PTRUC ), IU, JU, DESCU, WORK( PTRVT ),
     $               WORK( PTRVTC ), IVT, JVT, DESCVT, THRESH,
     $               RESULT, DELTA, WORK( PTRWORK ), -1 )
      WPSSVDCMP = INT( WORK( PTRWORK ) )
*
*     Calculation of workspace at last.
*
      LWMIN = 1 + 2*LDA*NQ + 3*SIZE +
     $        MAX( WPSLAGGE, LDU*SIZEQ+LDVT*NQ+MAX( LDU*SIZEQ,
     $        LDVT*NQ )+WPSGESVD+MAX( WPSSVDCHK, WPSSVDCMP ) )
      WORK( 1 ) = LWMIN
*
*     If this is a "dummy" call, return.
*
      IF( LWORK.EQ.-1 )
     $   GO TO 120
      IF( INFO.EQ.0 ) THEN
         IF( LWORK.LT.LWMIN ) THEN
            INFO = -10
         END IF
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL PXERBLA( DESCA( CTXT_ ), 'PSSVDTST', -INFO )
         RETURN
      END IF
*
      ULP = PSLAMCH( CONTEXT, 'P' )
      UNFL = PSLAMCH( CONTEXT, 'Safe min' )
      OVFL = ONE / UNFL
      CALL SLABAD( UNFL, OVFL )
      RTUNFL = SQRT( UNFL )
      RTOVFL = SQRT( OVFL )
*
*     This ensures that everyone starts out with the same seed.
*
      IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
         CALL IGEBS2D( CONTEXT, 'a', ' ', 4, 1, ISEED, 4 )
      ELSE
         CALL IGEBR2D( CONTEXT, 'a', ' ', 4, 1, ISEED, 4, 0, 0 )
      END IF
*
*     Loop over matrix types.
*
      DO 100 ITYPE = 1, NTYPES
*
         PASS = 0
         SETHET = 0
         PTRWORK = PTRSC + SIZE
         LLWORK = LWORK - PTRWORK + 1
*
*        Compute A.
*
         IF( ITYPE.EQ.1 ) THEN
*
*           Zero Matrix.
*
            DO 10 I = 1, SIZE
               WORK( PTRD+I-1 ) = ZERO
   10       CONTINUE
*
            CALL PSLASET( 'All', M, N, ZERO, ZERO, WORK( PTRA ),
     $                    IA, JA, DESCA )
*
         ELSE IF( ITYPE.EQ.2 ) THEN
*
*           Identity Matrix.
*
            DO 20 I = 1, SIZE
               WORK( PTRD+I-1 ) = ONE
   20       CONTINUE
*
            CALL PSLASET( 'All', M, N, ZERO, ONE, WORK( PTRA ),
     $                    IA, JA, DESCA )
*
         ELSE IF( ITYPE.GT.2 ) THEN
*
*           Preset Singular Values.
*
            IF( SIZE.NE.1 ) THEN
               H = ( ULP-1 ) / ( SIZE-1 )
               DO 30 I = 1, SIZE
                  WORK( PTRD+I-1 ) = 1 + H*( I-1 )
   30          CONTINUE
            ELSE
               WORK( PTRD ) = 1
            END IF
*
            IF( ITYPE.EQ.3 ) THEN
*
*              Diagonal Matrix with specified singular values.
*
               CALL PSLASET( 'All', M, N, ZERO, ZERO, WORK( PTRA ),
     $                       IA, JA, DESCA )
*
               DO 40 I = 1, SIZE
                  CALL PSELSET( WORK( PTRA ), I, I, DESCA,
     $                          WORK( PTRD+I-1 ) )
   40          CONTINUE
*
            ELSE IF( ITYPE.EQ.4 ) THEN
*
*              General matrix with specified singular values.
*
               CALL PSLAGGE( M, N, WORK( PTRD ), WORK( PTRA ), IA, JA,
     $                       DESCA, ISEED, SIZE, WORK( PTRWORK ),
     $                       LLWORK, INFO )
*
            ELSE IF( ITYPE.EQ.5 ) THEN
*
*              Singular values scaled by overflow.
*
               CALL SSCAL( SIZE, RTOVFL, WORK( PTRD ), 1 )
*
               CALL PSLAGGE( M, N, WORK( PTRD ), WORK( PTRA ), IA, JA,
     $                       DESCA, ISEED, SIZE, WORK( PTRWORK ),
     $                       LLWORK, INFO )
*
            ELSE IF( ITYPE.EQ.6 ) THEN
*
*              Singular values scaled by underflow.
*
               CALL SSCAL( SIZE, RTUNFL, WORK( PTRD ), 1 )
               CALL PSLAGGE( M, N, WORK( PTRD ), WORK( PTRA ), IA, JA,
     $                       DESCA, ISEED, SIZE, WORK( PTRWORK ),
     $                       LLWORK, INFO )
*
            END IF
*
         END IF
*
*        Set mapping between JOBTYPE and calling parameters of
*        PSGESVD, reset pointers to WORK array to save space.
*
         DO 80 JOBTYPE = 1, 4
*
            IF( JOBTYPE.EQ.1 ) THEN
               JOBU = 'V'
               JOBVT = 'V'
               PTRVT = PTRU + LDU*SIZEQ
               PTRUC = PTRVT + LDVT*NQ
               PTRWORK = PTRUC + LDU*SIZEQ
               LLWORK = LWORK - PTRWORK + 1
            ELSE IF( JOBTYPE.EQ.2 ) THEN
               JOBU = 'V'
               JOBVT = 'N'
            ELSE IF( JOBTYPE.EQ.3 ) THEN
               JOBU = 'N'
               JOBVT = 'V'
               PTRVTC = PTRUC
               PTRWORK = PTRVTC + LDVT*NQ
               LLWORK = LWORK - PTRWORK + 1
            ELSE IF( JOBTYPE.EQ.4 ) THEN
               JOBU = 'N'
               JOBVT = 'N'
               PTRWORK = PTRUC
               LLWORK = LWORK - PTRWORK + 1
            END IF
*
*           Duplicate matrix A.
*
            CALL PSLACPY( 'A', M, N, WORK( PTRA ), IA, JA, DESCA,
     $                    WORK( PTRAC ), IA, JA, DESCA )
*
*           Test SVD calculation with minimum amount of workspace
*           calculated earlier.
*
            IF( JOBTYPE.EQ.1 ) THEN
*
*              Run SVD.
               CALL SLBOOT
               CALL BLACS_BARRIER( CONTEXT, 'All' )
               CALL SLTIMER( 1 )
*
               CALL PSGESVD( JOBU, JOBVT, M, N, WORK( PTRAC ), IA, JA,
     $                       DESCA, WORK( PTRS ), WORK( PTRU ), IU, JU,
     $                       DESCU, WORK( PTRVT ), IVT, JVT, DESCVT,
     $                       WORK( PTRWORK ), WPSGESVD, INFO )
*
               CALL SLTIMER( 1 )
               CALL SLCOMBINE( CONTEXT, 'All', '>', 'W', 1, 1, WTIME )
               CALL SLCOMBINE( CONTEXT, 'All', '>', 'C', 1, 1, CTIME )
*
*              Check INFO. Different INFO for  different processes mean
*              something went wrong.
*
               ITMP( 1 ) = INFO
               ITMP( 2 ) = INFO
*
               CALL IGAMN2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP, 1, 1,
     $                       1, -1, -1, 0 )
               CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, ITMP( 2 ),
     $                       1, 1, 1, -1, -1, 0 )
*
               IF( ITMP( 1 ).NE.ITMP( 2 ) ) THEN
                  IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
                     WRITE( NOUT, FMT = * )
     $                  'Different processes return different INFO'
                     GO TO 120
                  END IF
               END IF
*
*              If INFO is  negative PXERBLA tells you. So the only thing
*              is to check for positive INFO -- detected heterogeneous
*              system.
*
               IF( INFO.EQ.( SIZE+1 ) ) THEN
                  HETERO = 'P'
                  SETHET = 1
               END IF
*
*              If INFO was fine do more exhaustive check.
*
               IF( INFO.EQ.ZERO ) THEN
*
                  DO 50 I = 1, SIZE
                     WORK( I+PTRWORK ) = WORK( I+PTRS-1 )
                     WORK( I+SIZE+PTRWORK ) = WORK( I+PTRS-1 )
   50             CONTINUE
*
                  CALL SGAMN2D( DESCA( CTXT_ ), 'a', ' ', SIZE, 1,
     $                          WORK( 1+PTRWORK ), SIZE, 1, 1, -1, -1,
     $                          0 )
                  CALL SGAMX2D( DESCA( CTXT_ ), 'a', ' ', SIZE, 1,
     $                          WORK( 1+SIZE+PTRWORK ), SIZE, 1, 1, -1,
     $                          -1, 0 )
*
                  DO 60 I = 1, SIZE
                     IF( ABS( WORK( I+PTRWORK )-WORK( SIZE+I+
     $                   PTRWORK ) ).GT.ZERO ) THEN
                        WRITE( NOUT, FMT = * )'I= ', I, ' MIN=',
     $                     WORK( I+PTRWORK ), ' MAX=',
     $                     WORK( SIZE+I+PTRWORK )
                        HETERO = 'T'
                        SETHET = 1
                        GO TO 70
                     END IF
*
   60             CONTINUE
   70             CONTINUE
*
               END IF
*
               IF( SETHET.NE.1 )
     $            HETERO = 'N'
*
*              After PSGESVD AC got screwed up -- need to copy again.
*
               CALL PSLACPY( 'A', M, N, WORK( PTRA ), IA, JA, DESCA,
     $                       WORK( PTRAC ), IA, JA, DESCA )
*
*              PSSVDCHK screws up U. So before the call to PSSVDCHK
*              U is copied to UC and a pointer to UC is passed to
*              PSSVDCHK.
*
               CALL PSLACPY( 'A', M, SIZE, WORK( PTRU ), IU, JU, DESCU,
     $                       WORK( PTRUC ), IU, JU, DESCU )
*
*              Run tests 1 - 4.
*
               CALL PSSVDCHK( M, N, WORK( PTRAC ), IA, JA, DESCA,
     $                        WORK( PTRUC ), IU, JU, DESCU,
     $                        WORK( PTRVT ), IVT, JVT, DESCVT,
     $                        WORK( PTRS ), THRESH, WORK( PTRWORK ),
     $                        LLWORK, RESULT, CHK, MTM )
*
            ELSE
*
*              Once again test PSGESVD with min workspace.
*
               CALL PSGESVD( JOBU, JOBVT, M, N, WORK( PTRAC ), IA, JA,
     $                       DESCA, WORK( PTRSC ), WORK( PTRUC ), IU,
     $                       JU, DESCU, WORK( PTRVTC ), IVT, JVT,
     $                       DESCVT, WORK( PTRWORK ), WPSGESVD, INFO )
*
               CALL PSSVDCMP( M, N, JOBTYPE, WORK( PTRS ),
     $                        WORK( PTRSC ), WORK( PTRU ),
     $                        WORK( PTRUC ), IU, JU, DESCU,
     $                        WORK( PTRVT ), WORK( PTRVTC ), IVT, JVT,
     $                        DESCVT, THRESH, RESULT, DELTA,
     $                        WORK( PTRWORK ), LLWORK )
*
            END IF
*
   80    CONTINUE
*
         IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 ) THEN
            DO 90 I = 1, 9
               IF( RESULT( I ).EQ.1 ) THEN
                  PASS = 1
                  WRITE( NOUT, FMT = * )'Test I = ', I, 'has failed'
                  WRITE( NOUT, FMT = * )' '
               END IF
   90       CONTINUE
            IF( PASS.EQ.0 ) THEN
               WRITE( NOUT, FMT = 9999 )'Passed', WTIME( 1 ),
     $            CTIME( 1 ), M, N, NPROW, NPCOL, NB, ITYPE, CHK, MTM,
     $            DELTA, HETERO
            END IF
         END IF
  100 CONTINUE
      CALL BLACS_GRIDEXIT( CONTEXT )
  110 CONTINUE
*
 9999 FORMAT( A6, 2E10.3, 2I6, 2I4, I5, I6, 3F6.2, 4X, A1 )
  120 CONTINUE
*
*     End of PSSVDTST
*
      RETURN
      END


!Joshua Dorrington 22/03/18 - University of Oxford
!This module contains all the parameters, physical and otherwise
module params

	use, intrinsic :: iso_fortran_env

    	implicit none
	!global constants
	integer, parameter :: dp = real64
	real(dp), parameter :: pi = 4._dp*ATAN(1._dp)

	!model timestepping params
	real(dp), parameter :: dt =2e-4_dp
	real(dp), parameter :: t_0=0._dp
	real(dp), parameter :: t_f=200000._dp
	real(dp), parameter :: sample_t =1._dp

		!derived timestepping parameters, don't touch directly
		integer(kind=int64), parameter :: step_num=(t_f-t_0)/dt
		integer, parameter :: sample_num=int((t_f-t_0)/sample_t)

	!model params:
	character(len=1024), parameter :: save_file = SUB_SAVE_FILE
	!strength of stochasticity
	real(dp), parameter :: sigma = SUB_SIGMA
	!noise type, "w"=white noise, "r" = red noise
	character, parameter :: noise_type=SUB_NOISE_TYPE
	!correlation of noise (only for noise type ='r')
	real(dp), parameter :: r=SUB_R
	!number of dimensions, and codimensions
	integer, parameter :: dims=6
	integer, parameter :: coeff_num =11

	!array like params, the initial condition and the forcing vector
	real(dp), parameter, dimension(dims) :: &
	init_con =(/0.927796_dp,0.160574_dp,-0.0969953_dp,-0.672758_dp,-0.118184_dp,0.214505_dp/)
	real(dp), parameter, dimension(dims) :: &
	xf=(/0.95_dp,0._dp,0._dp,-0.76095_dp,0._dp,0._dp/)

	!forcing magnitude
	real(dp), parameter :: C=0.1_dp
	!strength of coriolis terms
	real(dp), parameter :: beta=1.25_dp
	!geometry of box; ratio of channel length to width
	real(dp), parameter :: b=0.5_dp
	!topographical height parameter
	real(dp), parameter :: g=0.2_dp

end module params


  FUNCTION LeftWall( Model, n, t ) RESULT(f)

    USE Types
    USE SolverUtils
    USE Lists
    USE Integration
    USE ElementDescription
    USE ElementUtils
    USE DefUtils

    IMPLICIT NONE

    TYPE(Model_t) :: Model
    INTEGER :: n
    REAL(KIND=dp) :: t,f
!-----------------------------------------------------
    LOGICAL :: Visited = .FALSE.,Found, FixedArea, IsLeftWall
    INTEGER :: i,j,Nopt,Power1,Nleft,Nboth,nstart,nfin
    REAL(KIND=dp) :: x,y,fi
    TYPE(Variable_t), POINTER :: OptSol
    REAL(KIND=dp), POINTER :: Opt(:)

    SAVE Visited, Opt, Nopt, Power1, Nleft, Nboth, nstart, nfin, FixedArea

    IsLeftWall = .TRUE.

    IF(.NOT. Visited) THEN
      FixedArea = ListGetLogical( Model % Simulation,'Fixed Area',Found)
      OptSol => VariableGet( Model % Variables, 'opt' )
      IF( ASSOCIATED( OptSol ) ) THEN
        Opt => OptSol % Values
        Nopt = SIZE( Opt )
      ELSE
        ALLOCATE( Opt(10) )

        ! Shorter names may be needed for some uses
        IF(.FALSE.) THEN
           Opt(1) = ListGetConstReal( Model % Simulation,'Left Wall B1',Found)
           Opt(3) = ListGetConstReal( Model % Simulation,'Left Wall B2',Found)
           Opt(5) = ListGetConstReal( Model % Simulation,'Left Wall B3',Found)
           Opt(7) = ListGetConstReal( Model % Simulation,'Left Wall B4',Found)
           Opt(9) = ListGetConstReal( Model % Simulation,'Left Wall B5',Found)

           Opt(2) = ListGetConstReal( Model % Simulation,'Right Wall B1',Found)
           Opt(4) = ListGetConstReal( Model % Simulation,'Right Wall B2',Found)
           Opt(6) = ListGetConstReal( Model % Simulation,'Right Wall B3',Found)
           Opt(8) = ListGetConstReal( Model % Simulation,'Right Wall B4',Found)
           Opt(10) = ListGetConstReal( Model % Simulation,'Right Wall B5',Found)
        ELSE
           Opt(1) = ListGetConstReal( Model % Simulation,'LB1',Found)
           Opt(3) = ListGetConstReal( Model % Simulation,'LB2',Found)
           Opt(5) = ListGetConstReal( Model % Simulation,'LB3',Found)
           Opt(7) = ListGetConstReal( Model % Simulation,'LB4',Found)
           Opt(9) = ListGetConstReal( Model % Simulation,'LB5',Found)

           Opt(2) = ListGetConstReal( Model % Simulation,'RB1',Found)
           Opt(4) = ListGetConstReal( Model % Simulation,'RB2',Found)
           Opt(6) = ListGetConstReal( Model % Simulation,'RB3',Found)
           Opt(8) = ListGetConstReal( Model % Simulation,'RB4',Found)
           Opt(10) = ListGetConstReal( Model % Simulation,'RB5',Found)
        END IF

        IF( FixedArea ) THEN
          Nopt = 9
          Opt(2:9) = Opt(3:10)
        ELSE
          Nopt = 10
        END IF
      END IF

      Visited = .TRUE.

      Power1 = 2
      IF( FixedArea ) THEN
        nstart = 2
      ELSE
        nstart = 3
      END IF

      Nfin = Nopt
    END IF

    x = Model % Nodes % x(n)
    y = Model % Nodes % y(n)
    y = 1 - y

    f = 0.0_dp
    IF( IsLeftWall .OR. FixedArea ) THEN
      f = f + Opt(1) * y
    ELSE
      f = f + Opt(2) * y
    END IF

    i = Power1
    IF( IsLeftWall ) THEN
      DO j=nstart,nfin,2
        fi = (i+1)*y**i - i*y**(i-1)
        f = f + Opt(j) * fi
        i = i + 1
      END DO
    ELSE
      DO j=nstart,nfin,2
        fi = (i+1)*y**i - i*y**(i-1)
        f = f + Opt(j+1) * fi
        i = i + 1
      END DO
    END IF

!    PRINT *,'y',y,'dx',f,'Opt',Power1,Opt

  END FUNCTION LeftWall

  FUNCTION RightWall( Model, n, t ) RESULT(f)

    USE Types
    USE SolverUtils
    USE Lists
    USE Integration
    USE ElementDescription
    USE ElementUtils
    USE DefUtils

    IMPLICIT NONE

    TYPE(Model_t) :: Model
    INTEGER :: n
    REAL(KIND=dp) :: t,f
!-----------------------------------------------------
    LOGICAL :: Visited = .FALSE.,Found, FixedArea, IsLeftWall
    INTEGER :: i,j,Nopt,Power1,Nleft,Nboth,nstart,nfin
    REAL(KIND=dp) :: x,y,fi
    TYPE(Variable_t), POINTER :: OptSol
    REAL(KIND=dp), POINTER :: Opt(:)

    SAVE Visited, Opt, Nopt, Power1, Nleft, Nboth, nstart, nfin, FixedArea

    IsLeftWall = .FALSE.

    IF(.NOT. Visited) THEN
      FixedArea = ListGetLogical( Model % Simulation,'Fixed Area',Found)
      OptSol => VariableGet( Model % Variables, 'opt' )

      IF( ASSOCIATED( OptSol ) ) THEN
        Opt => OptSol % Values
        Nopt = SIZE( Opt )
      ELSE
        ALLOCATE( Opt(10) )

        IF(.FALSE.) THEN
           Opt(1) = ListGetConstReal( Model % Simulation,'Left Wall B1',Found)
           Opt(3) = ListGetConstReal( Model % Simulation,'Left Wall B2',Found)
           Opt(5) = ListGetConstReal( Model % Simulation,'Left Wall B3',Found)
           Opt(7) = ListGetConstReal( Model % Simulation,'Left Wall B4',Found)
           Opt(9) = ListGetConstReal( Model % Simulation,'Left Wall B5',Found)

           Opt(2) = ListGetConstReal( Model % Simulation,'Right Wall B1',Found)
           Opt(4) = ListGetConstReal( Model % Simulation,'Right Wall B2',Found)
           Opt(6) = ListGetConstReal( Model % Simulation,'Right Wall B3',Found)
           Opt(8) = ListGetConstReal( Model % Simulation,'Right Wall B4',Found)
           Opt(10) = ListGetConstReal( Model % Simulation,'Right Wall B5',Found)
        ELSE
           Opt(1) = ListGetConstReal( Model % Simulation,'LB1',Found)
           Opt(3) = ListGetConstReal( Model % Simulation,'LB2',Found)
           Opt(5) = ListGetConstReal( Model % Simulation,'LB3',Found)
           Opt(7) = ListGetConstReal( Model % Simulation,'LB4',Found)
           Opt(9) = ListGetConstReal( Model % Simulation,'LB5',Found)

           Opt(2) = ListGetConstReal( Model % Simulation,'RB1',Found)
           Opt(4) = ListGetConstReal( Model % Simulation,'RB2',Found)
           Opt(6) = ListGetConstReal( Model % Simulation,'RB3',Found)
           Opt(8) = ListGetConstReal( Model % Simulation,'RB4',Found)
           Opt(10) = ListGetConstReal( Model % Simulation,'RB5',Found)
        END IF

        IF( FixedArea ) THEN
          Nopt = 9
          Opt(2:9) = Opt(3:10)
        ELSE
          Nopt = 10
        END IF
      END IF

      Visited = .TRUE.

      Power1 = 2
      IF( FixedArea ) THEN
        nstart = 2
      ELSE
        nstart = 3
      END IF

      Nfin = Nopt
    END IF

    x = Model % Nodes % x(n)
    y = Model % Nodes % y(n)
    y = 1 - y

    f = 0.0_dp
    IF( IsLeftWall .OR. FixedArea ) THEN
      f = f + Opt(1) * y
    ELSE
      f = f + Opt(2) * y
    END IF

    i = Power1
    IF( IsLeftWall ) THEN
      DO j=nstart,nfin,2
        fi = (i+1)*y**i - i*y**(i-1)
        f = f + Opt(j) * fi
        i = i + 1
      END DO
    ELSE
      DO j=nstart,nfin,2
        fi = (i+1)*y**i - i*y**(i-1)
        f = f + Opt(j+1) * fi
        i = i + 1
      END DO
    END IF

!    PRINT *,'y',y,'dx',f,'Opt',Power1,Opt

  END FUNCTION RightWall


!     DSYEV Example Program Text
!     NAG Copyright 2006.
!     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        (NIN=5,NOUT=6)
      INTEGER          NB, NMAX
      PARAMETER        (NB=64,NMAX=10)
      INTEGER          LDA, LWORK
      PARAMETER        (LDA=NMAX,LWORK=(NB+2)*NMAX)
!     .. Local Scalars ..
      DOUBLE PRECISION EERRBD, EPS
      INTEGER          I, IFAIL, INFO, J, LWKOPT, N
!     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), RCONDZ(NMAX), W(NMAX), WORK(LWORK), &
                      ZERRBD(NMAX)
!     .. External Functions ..
      DOUBLE PRECISION DLAMCH
      EXTERNAL         DLAMCH
!     .. External Subroutines ..
      EXTERNAL         DDISNA, DSYEV, X04CAF
!     .. Intrinsic Functions ..
      INTRINSIC        ABS, MAX
!     .. Executable Statements ..
      WRITE (NOUT,*) 'DSYEV Example Program Results'
      WRITE (NOUT,*)
!     Skip heading in data file
      READ (NIN,*)
      READ (NIN,*) N
      IF (N.LE.NMAX) THEN
!
!        Read the upper triangular part of the matrix A from data file
!
         READ (NIN,*) ((A(I,J),J=I,N),I=1,N)
!
!        Solve the symmetric eigenvalue problem
!
         CALL DSYEV('Vectors','Upper',N,A,LDA,W,WORK,LWORK,INFO)
         LWKOPT = WORK(1)
!
         IF (INFO.EQ.0) THEN
!
!           Print solution
!
            WRITE (NOUT,*) 'Eigenvalues'
            WRITE (NOUT,99999) (W(J),J=1,N)
!
            IFAIL = 0
!!!!!            CALL X04CAF('General',' ',N,N,A,LDA,'Eigenvectors',IFAIL)
!
!           Get the machine precision, EPS and compute the approximate
!           error bound for the computed eigenvalues.  Note that for
!           the 2-norm, max( abs(W(i)) ) = norm(A), and since the
!           eigenvalues are returned in ascending order
!           max( abs(W(i)) ) = max( abs(W(1)), abs(W(n)))
!
            EPS = DLAMCH('Eps')
            EERRBD = EPS*MAX(ABS(W(1)),ABS(W(N)))
!
!           Call  DDISNA  to estimate reciprocal condition
!           numbers for the eigenvectors
!
            CALL DDISNA('Eigenvectors',N,N,W,RCONDZ,INFO)
!
!           Compute the error estimates for the eigenvectors
!
            DO 20 I = 1, N
               ZERRBD(I) = EERRBD/RCONDZ(I)
   20       CONTINUE
!
!           Print the approximate error bounds for the eigenvalues
!           and vectors
!
            WRITE (NOUT,*)
            WRITE (NOUT,*) 'Error estimate for the eigenvalues'
            WRITE (NOUT,99998) EERRBD
            WRITE (NOUT,*)
            WRITE (NOUT,*) 'Error estimates for the eigenvectors'
            WRITE (NOUT,99998) (ZERRBD(I),I=1,N)
         ELSE
            WRITE (NOUT,99997) 'Failure in DSYEV. INFO =', INFO
         END IF
!
!        Print workspace information
!
         IF (LWORK.LT.LWKOPT) THEN
            WRITE (NOUT,*)
            WRITE (NOUT,99996) 'Optimum workspace required = ', LWKOPT, &
             'Workspace provided         = ', LWORK
         END IF
      ELSE
         WRITE (NOUT,*) 'NMAX too small'
      END IF
      STOP
!
99999 FORMAT (3X,(8F8.4))
99998 FORMAT (4X,1P,6E11.1)
99997 FORMAT (1X,A,I4)
99996 FORMAT (1X,A,I5,/1X,A,I5)
      END


c
c-----------------------------------------------------------------------
c subroutine:  fsst
c fourier synthesis subroutine
c-----------------------------------------------------------------------
c
      subroutine fsst(b, n)
c
c this subroutine synthesizes the real vector b(k), for
c k=1,2,...,n, from the fourier coefficients stored in the
c b array of size n+2.  the dc term is in b(1) with b(2) equal
c to  0.  the jth harmonic is stored as b(2*j+1) + i b(2*j+2).
c the n/2 harmonic is in b(n+1) with b(n+2) equal to 0.
c the subroutine is called as fsst(b,n) where n=2**m and
c b is the real array discussed above.
c
      dimension b(2)
      common /const/ pii, p7, p7two, c22, s22, pi2
c
c iw is a machine dependent write device number
c
      iw = i1mach(2)
c
      pii = 4.*atan(1.)
      pi8 = pii/8.
      p7 = 1./sqrt(2.)
      p7two = 2.*p7
      c22 = cos(pi8)
      s22 = sin(pi8)
      pi2 = 2.*pii
      do 10 i=1,15
        m = i
        nt = 2**i
        if (n.eq.nt) go to 20
  10  continue
      write (iw,9999)
9999  format (33h n is not a power of two for fsst)
      stop
  20  b(2) = b(n+1)
      do 30 i=4,n,2
        b(i) = -b(i)
  30  continue
c
c scale the input by n
c
      do 40 i=1,n
        b(i) = b(i)/float(n)
  40  continue
      n4pow = m/2
c
c scramble the inputs
c
      call ford2(m, b)
      call ford1(m, b)
c
      if (n4pow.eq.0) go to 60
      nn = 4*n
      do 50 it=1,n4pow
        nn = nn/4
        int = n/nn
        call fr4syn(int, nn, b(1), b(int+1), b(2*int+1), b(3*int+1),
     *      b(1), b(int+1), b(2*int+1), b(3*int+1))
  50  continue
c
c do a radix 2 iteration if one is required
c
  60  if (m-n4pow*2) 80, 80, 70
  70  int = n/2
      call fr2tr(int, b(1), b(int+1))
  80  return
      end


C NCLFORTSTART
      SUBROUTINE DVRFIDF(U,V,GLAT,GLON,MLON,NLAT,XMSG,IOPT,RV,IER)
      IMPLICIT NONE

c relative vorticity via finite differences
c NCL: rv = uv2vr_cfd (u,v,lat,lon,cyclic)

c            xmsg = u@_FillValue
c            nlat,mlon = dimsizes (u)
c            iopt= cyclic

c relative vorticity via centered finite difference approach (rv)
c .  rv = dv/dx-du/dy+(u/a)tan(lat)   where "d" means partial derivitive
c reference: Bluestein p113-114 [was not the original reference]
c            Halt-Martin p314   [ nothing on rv]

c assumptions:
c .   (1) latitudes  monotonically increasing  [eg: glat(2) > glat(1)]
c .                  latitudes may be unequally spaced
c .   (2) longitudes monotonically increasing  [eg: glon(2) > glon(1)]
c .                  longitudes are assmed to be equally spaced
c .   (3) if iopt=1 then the grids are cyclic in x
c .                  eg: for T42 grid mlon=128, nlat=64
c .                      cyclic point should NOT be included
c .
c                                          ! INPUT
      INTEGER MLON,NLAT
      DOUBLE PRECISION U(MLON,NLAT),V(MLON,NLAT),GLAT(NLAT),GLON(MLON),
     +                 XMSG
      INTEGER IOPT

c                                          ! OUTPUT
      DOUBLE PRECISION RV(MLON,NLAT)
      INTEGER IER
C NCLEND
c                                          ! LOCAL  (dynamic/adjustable)
      DOUBLE PRECISION CLAT(NLAT),DX(NLAT),DLON,DX2(NLAT),DLON2,
     +                 DY2(NLAT),DYTOP,DYBOT,RE,RAD,RCON,
     +                 POLAT,TLATRE(NLAT)
      INTEGER ML,NL,MLSTRT,MLEND,MLM1,MLP1,JOPT

c                                          ! error chk stuff
      IER = 0
      IF (MLON.LT.1 .OR. NLAT.LT.1) THEN
          IER = 1
          RETURN
      END IF
      IF (ABS(GLAT(1)).gt.90.D0 .OR. ABS(GLAT(NLAT)).GT.90.D0) THEN
          IER = 2
          RETURN
      END IF

      RE = 6.37122D06
      RAD = 4.D0*ATAN(1.D0)/180.D0
      RCON = RE*RAD
      JOPT = ABS(IOPT)
c                                 ! pre-compute cos(lat)
      DO NL = 1,NLAT
          CLAT(NL)   = COS(RAD*GLAT(NL))
      END DO
c                                 ! pre-compute tan(lat)/re
c                                 ! pole pts will not be used below
      DO NL = 1,NLAT
         IF (ABS(GLAT(NL)).LT.90.D0) THEN
             TLATRE(NL) = TAN(RAD*GLAT(NL))/RE
         ELSE
             IF (GLAT(NL).EQ.90.D0) THEN
                 POLAT = 0.5*(GLAT(NL)+GLAT(NL-1))
                 TLATRE(NL) = TAN(RAD*POLAT)/RE
             ELSE
                 POLAT = 0.5*(GLAT(NL)+GLAT(NL+1))
                 TLATRE(NL) = TAN(RAD*POLAT)/RE
             END IF
         END IF
      END DO

c                                          ! initialize to msg
      DO NL = 1,NLAT
          DO ML = 1,MLON
              RV(ML,NL) = XMSG
          END DO
      END DO
c                                          ! calculate "1/dy" [bot, top]
      DYBOT = 1.D0/ (RCON* (GLAT(2)-GLAT(1)))
      DYTOP = 1.D0/ (RCON* (GLAT(NLAT)-GLAT(NLAT-1)))
c                                          ! calculate "1/(2*dy)"
      DO NL = 2,NLAT - 1
          DY2(NL) = 1.D0/ (RCON* (GLAT(NL+1)-GLAT(NL-1)))
      END DO
c                                       ! calculate "1/dx" [left, right]
c                                       ! and "1/(2*dx)
      DLON = GLON(2) - GLON(1)
      DLON2 = GLON(3) - GLON(1)

      DO NL = 1,NLAT
          IF (ABS(GLAT(NL)).NE.90.D0) THEN
              DX(NL) = 1.D0/ (RCON*DLON*CLAT(NL))
              DX2(NL) = 1.D0/ (RCON*DLON2*CLAT(NL))
          ELSE
              DX(NL) = 0.0D0
              DX2(NL) = 0.0D0
          END IF
      END DO
c                                          ! set subscript range
      IF (JOPT.EQ.1 .OR. JOPT.EQ.3) THEN
          MLSTRT = 1
          MLEND = MLON
      ELSE
          MLSTRT = 2
          MLEND = MLON - 1
      END IF
c                                          ! longitude loop
      DO ML = MLSTRT,MLEND
c                                          ! iopt=0 or 1
          MLM1 = ML - 1
          MLP1 = ML + 1
          IF (ML.EQ.1) MLM1 = MLON
          IF (ML.EQ.MLON) MLP1 = 1
c                                          ! rv in grid body
          DO NL = 2,NLAT - 1
              IF (V(MLP1,NL).NE.XMSG .AND. V(MLM1,NL).NE.XMSG .AND.
     +            U(ML,NL+1).NE.XMSG .AND. U(ML,NL-1).NE.XMSG .AND.
     +            U(ML,NL)  .NE.XMSG) THEN

                  RV(ML,NL) = (V(MLP1,NL)-V(MLM1,NL))*DX2(NL) -
     +                        (U(ML,NL+1)-U(ML,NL-1))*DY2(NL) +
     +                         U(ML,NL)*TLATRE(NL)

              END IF
          END DO

          IF (JOPT.GE.2) THEN
c                                   ! bottom bound (nl=1)
              IF (V(MLP1,1).NE.XMSG .AND. V(MLM1,1).NE.XMSG .AND.
     +            U(ML,2)  .NE.XMSG .AND. U(ML,1)  .NE.XMSG) THEN

                  RV(ML,1) = (V(MLP1,1)-V(MLM1,1))*DX2(1) -
     +                       (U(ML,2)-U(ML,1))*DYBOT      +
     +                        U(ML,1)*TLATRE(1)
              END IF
c                                   ! top bound   (nl=nlat)
              IF (V(MLP1,NLAT).NE.XMSG .AND. V(MLM1,NLAT).NE.XMSG .AND.
     +            U(ML,NLAT)  .NE.XMSG .AND. U(ML,NLAT-1).NE.XMSG)THEN

                  RV(ML,NLAT) = (V(MLP1,NLAT)-V(MLM1,NLAT))*DX2(NLAT) -
     +                          (U(ML,NLAT)-U(ML,NLAT-1))*DYTOP       +
     +                           U(ML,NLAT)*TLATRE(NLAT)
              END IF
          END IF
      END DO
c                                   ! ?left/right bound?
      IF (JOPT.EQ.2) THEN
          DO NL = 2,NLAT - 1
c                                   ! left bound (ml=1)
              IF (V(2,NL).NE.XMSG   .AND. V(1,NL)  .NE.XMSG .AND.
     +            U(1,NL+1).NE.XMSG .AND. U(1,NL-1).NE.XMSG .AND.
     +            U(1,NL)  .NE.XMSG) THEN

                  RV(1,NL) = (V(2,NL)-V(1,NL))*DX(NL)      -
     +                       (U(1,NL+1)-U(1,NL-1))*DY2(NL) +
     +                        U(1,NL)*TLATRE(NL)
              END IF
c                                   ! right bound (ml=mlon)
              IF (V(MLON,NL)  .NE.XMSG .AND. V(MLON-1,NL).NE.XMSG .AND.
     +            U(MLON,NL+1).NE.XMSG .AND. U(MLON,NL-1).NE.XMSG .AND.
     +            U(MLON,NL)  .NE.XMSG) THEN

                  RV(MLON,NL) = (V(MLON,NL)-V(MLON-1,NL))*DX(NL)    -
     +                          (U(MLON,NL+1)-U(MLON,NL-1))*DY2(NL) +
     +                           U(MLON,NL)*TLATRE(NL)
              END IF
          END DO
      END IF
c                                   ! special at +/-90 use average
      DO NL = 1,NLAT,NLAT - 1
        IF (ABS(GLAT(NL)).EQ.90.D0) CALL DUSEAVE(RV(1,NL),MLON,XMSG)
      END DO
c                                   ! special for corners (jopt=2 only)
c                                   ! use linear extrapolation from
c                                   ! two directions
      IF (JOPT.EQ.2) THEN
          CALL DLNEXTRP(RV,MLON,NLAT,XMSG)
      END IF

      RETURN
      END

c NCLFORTSTART
      SUBROUTINE DDVFIDF(U,V,GLAT,GLON,MLON,NLAT,XMSG,IOPT,DV,IER)
      IMPLICIT NONE

c divergence via centered finite differences
c . div = dv/dy+du/dx-(v/re)*tan(lat)  where "d" ==> partial derivitive
c
c reference: Bluestein p113-114
c            Halt-Martin p314

c NCL: dv = uv2dv_cfd (u,v,lat,lon,cyclic)
c            xmsg = u@_FillValue
c            nlat,mlon = dimsizes (u)
c            iopt= cyclic

c assumptions:
c .   (1) latitudes  monotonically increasing  [eg: glat(2) > glat(1)]
c .                  latitudes may be unequally spaced
c .   (2) longitudes monotonically increasing  [eg: glon(2) > glon(1)]
c .                  longitudes are assmed to be equally spaced
c .   (3) if iopt=1 then the grids are cyclic in x
c .                  eg: for T42 grid mlon=128, nlat=64
c .                      cyclic point should NOT be included
c .

c                                          ! INPUT
      INTEGER MLON,NLAT
      DOUBLE PRECISION U(MLON,NLAT),V(MLON,NLAT),GLAT(NLAT),GLON(MLON),
     +                 XMSG
      INTEGER IOPT

c                                          ! OUTPUT
      DOUBLE PRECISION DV(MLON,NLAT)
      INTEGER IER
C NCLEND
c                                          ! LOCAL  (dynamic/adjustable)
      DOUBLE PRECISION CLAT(NLAT),DX(NLAT),DLON,DX2(NLAT),DLON2,
     +                 DY2(NLAT),DYTOP,DYBOT,RE,RAD,RCON,
     +                 POLAT,TLATRE(NLAT)
      INTEGER ML,NL,MLSTRT,MLEND,MLM1,MLP1,JOPT

c                                          ! error chk stuff
      IER = 0
      IF (MLON.LT.1 .OR. NLAT.LT.1) THEN
          IER = 1
          RETURN
      END IF
      IF (ABS(GLAT(1)).gt.90.D0 .OR. ABS(GLAT(NLAT)).GT.90.D0) THEN
          IER = 2
          RETURN
      END IF

      RE = 6.37122D06
      RAD = 4.D0*ATAN(1.D0)/180.D0
      RCON = RE*RAD
      JOPT = ABS(IOPT)
c                                 ! pre-compute cos(lat)
      DO NL = 1,NLAT
          CLAT(NL)   = COS(RAD*GLAT(NL))
      END DO
c                                 ! pre-compute tan(lat)/re
c                                 ! pole pts will not be used below
      DO NL = 1,NLAT
         IF (ABS(GLAT(NL)).LT.90.D0) THEN
             TLATRE(NL) = TAN(RAD*GLAT(NL))/RE
         ELSE
             IF (GLAT(NL).EQ.90.D0) THEN
                 POLAT = 0.5*(GLAT(NL)+GLAT(NL-1))
                 TLATRE(NL) = TAN(RAD*POLAT)/RE
             ELSE
                 POLAT = 0.5*(GLAT(NL)+GLAT(NL+1))
                 TLATRE(NL) = TAN(RAD*POLAT)/RE
             END IF
         END IF
      END DO
c                                          ! initialize to msg
      DO NL = 1,NLAT
          DO ML = 1,MLON
              DV(ML,NL) = XMSG
          END DO
      END DO
c                                          ! calculate "1/dy" [bot, top]
      DYBOT = 1.D0/ (RCON* (GLAT(2)-GLAT(1)))
      DYTOP = 1.D0/ (RCON* (GLAT(NLAT)-GLAT(NLAT-1)))
c                                          ! calculate "1/(2*dy)"
      DO NL = 2,NLAT - 1
          DY2(NL) = 1.D0/ (RCON* (GLAT(NL+1)-GLAT(NL-1)))
      END DO
c                                       ! calculate "1/dx" [left, right]
c                                       ! and "1/(2*dx)
      DLON = GLON(2) - GLON(1)
      DLON2 = GLON(3) - GLON(1)

      DO NL = 1,NLAT
          IF (ABS(GLAT(NL)).NE.90.D0) THEN
              DX(NL) = 1.D0/ (RCON*DLON*CLAT(NL))
              DX2(NL) = 1.D0/ (RCON*DLON2*CLAT(NL))
          ELSE
              DX(NL) = 0.0D0
              DX2(NL) = 0.0D0
          END IF
      END DO
c                                          ! set subscript range
      IF (JOPT.EQ.1 .OR. JOPT.EQ.3) THEN
          MLSTRT = 1
          MLEND = MLON
      ELSE
          MLSTRT = 2
          MLEND = MLON - 1
      END IF

      DO ML = MLSTRT,MLEND
          MLM1 = ML - 1
          MLP1 = ML + 1
          IF (ML.EQ.1) MLM1 = MLON
          IF (ML.EQ.MLON) MLP1 = 1
c                                          ! dv in grid body
          DO NL = 2,NLAT - 1
              IF (V(ML,NL+1).NE.XMSG .AND. V(ML,NL-1).NE.XMSG .AND.
     +            U(MLP1,NL).NE.XMSG .AND. U(MLM1,NL).NE.XMSG .AND.
     +            V(ML,NL)  .NE.XMSG) THEN

                  DV(ML,NL) = (V(ML,NL+1)-V(ML,NL-1))*DY2(NL) +
     +                        (U(MLP1,NL)-U(MLM1,NL))*DX2(NL) -
     +                         V(ML,NL)*TLATRE(NL)
              END IF
          END DO
c                                   ! ?bottom/top bound?
          IF (JOPT.GE.2) THEN
c                                   ! bottom bound (nl=1)
              IF (V(ML,2)  .NE.XMSG .AND. V(ML,1)  .NE.XMSG .AND.
     +            U(MLP1,2).NE.XMSG .AND. U(MLM1,1).NE.XMSG) THEN

                  DV(ML,1) = (V(ML,2)-V(ML,1))*DYBOT      +
     +                       (U(MLP1,1)-U(MLM1,1))*DX2(1) -
     +                        V(ML,1)*TLATRE(1)
              END IF
c                                   ! top bound   (nl=nlat)
              IF (V(ML,NLAT).NE.XMSG   .AND. V(ML,NLAT-1).NE.XMSG .AND.
     +            U(MLP1,NLAT).NE.XMSG .AND. U(MLM1,NLAT).NE.XMSG) THEN

                  DV(ML,NLAT) = (V(ML,NLAT)-V(ML,NLAT-1))*DYTOP      +
     +                          (U(MLP1,NLAT)-U(MLM1,NLAT))*DX2(NLAT)-
     +                           V(ML,NLAT)*TLATRE(NLAT)
              END IF
          END IF
      END DO
c                                   ! ?left/right bound?
      IF (JOPT.EQ.2) THEN
          DO NL = 2,NLAT - 1
c                                   ! left bound (ml=1)
              IF (V(1,NL+1).NE.XMSG .AND. V(1,NL-1).NE.XMSG .AND.
     +            U(2,NL)  .NE.XMSG .AND. U(1,NL)  .NE.XMSG .AND.
     +            V(1,NL)  .NE.XMSG) THEN

                  DV(1,NL) = (V(1,NL+1)-V(1,NL-1))*DY2(NL) +
     +                       (U(2,NL)-U(1,NL))*DX(NL) -
     +                        V(1,NL)*TLATRE(NL)
              END IF
c                                   ! right bound (ml=mlon)
              IF (V(MLON,NL+1).NE.XMSG .AND. V(MLON,NL-1).NE.XMSG .AND.
     +            U(MLON,NL)  .NE.XMSG .AND. U(MLON-1,NL).NE.XMSG .AND.
     +            V(MLON,NL)  .NE.XMSG) THEN

                  DV(MLON,NL) = (V(MLON,NL+1)-V(MLON,NL-1))*DY2(NL) +
     +                          (U(MLON,NL)-U(MLON-1,NL))*DX(NL) -
     +                           V(MLON,NL)*TLATRE(NL)
              END IF
          END DO
      END IF
c                                   ! special at +/-90 use average
      DO NL = 1,NLAT,NLAT - 1
        IF (ABS(GLAT(NL)).EQ.90.D0) CALL DUSEAVE(DV(1,NL),MLON,XMSG)
      END DO
c                                   ! special for corners (jopt=2 only)
c                                   ! use linear extrapolation from
c                                   ! two directions
      IF (JOPT.EQ.2) THEN
          CALL DLNEXTRP(DV,MLON,NLAT,XMSG)
      END IF

      RETURN
      END

      SUBROUTINE DLNEXTRP(X,MLON,NLAT,XMSG)
      IMPLICIT NONE

c linearly extrapolate from two directions [take average]
c .   for the corner pts

      INTEGER MLON,NLAT
      DOUBLE PRECISION X(MLON,NLAT),XMSG

      INTEGER ML,NL

      DO NL = 1,NLAT,NLAT - 1
          DO ML = 1,MLON,MLON - 1
              IF (X(ML,NL).EQ.XMSG) THEN
                  IF (NL.EQ.1 .AND. ML.EQ.1) THEN
                      IF (X(ML,NL+1).NE.XMSG .AND.
     +                    X(ML,NL+2).NE.XMSG .AND.
     +                    X(ML+1,NL).NE.XMSG .AND.
     +                    X(ML+2,NL).NE.XMSG) THEN
                          X(ML,NL) = (2.D0*X(ML,NL+1)-X(ML,NL+2)+
     +                               2.D0*X(ML+1,NL)-X(ML+2,NL))*0.5D0
                      END IF
                  END IF
                  IF (NL.EQ.1 .AND. ML.EQ.MLON) THEN
                      IF (X(ML,NL+1).NE.XMSG .AND.
     +                    X(ML,NL+2).NE.XMSG .AND.
     +                    X(ML-1,NL).NE.XMSG .AND.
     +                    X(ML-2,NL).NE.XMSG) THEN
                          X(ML,NL) = (2.D0*X(ML,NL+1)-X(ML,NL+2)+
     +                               2.D0*X(ML-1,NL)-X(ML-2,NL))*0.5D0
                      END IF
                  END IF
                  IF (NL.EQ.NLAT .AND. ML.EQ.1) THEN
                      IF (X(ML,NL-1).NE.XMSG .AND.
     +                    X(ML,NL-2).NE.XMSG .AND.
     +                    X(ML+1,NL).NE.XMSG .AND.
     +                    X(ML+2,NL).NE.XMSG) THEN
                          X(ML,NL) = (2.D0*X(ML,NL-1)-X(ML,NL-2)+
     +                               2.D0*X(ML+1,NL)-X(ML+2,NL))*0.5D0
                      END IF
                  END IF
                  IF (NL.EQ.NLAT .AND. ML.EQ.MLON) THEN
                      IF (X(ML,NL-1).NE.XMSG .AND.
     +                    X(ML,NL-2).NE.XMSG .AND.
     +                    X(ML-1,NL).NE.XMSG .AND.
     +                    X(ML-2,NL).NE.XMSG) THEN
                          X(ML,NL) = (2.D0*X(ML,NL-1)-X(ML,NL-2)+
     +                               2.D0*X(ML-1,NL)-X(ML-2,NL))*0.5D0
                      END IF
                  END IF
              END IF
          END DO
      END DO

      RETURN
      END

      SUBROUTINE DUSEAVE(X,MLON,XMSG)
      IMPLICIT NONE
c calculate average and use at all input grid points: +/- 90 only
      INTEGER MLON
      DOUBLE PRECISION X(MLON),XMSG
c                                   ! local
      INTEGER ML
      DOUBLE PRECISION AVE,CNT

      AVE = 0.0D0
      CNT = 0.0D0
      DO ML = 1,MLON
          IF (X(ML).NE.XMSG) THEN
              AVE = AVE + X(ML)
              CNT = CNT + 1.0D0
          END IF
      END DO

      IF (CNT.NE.0.0D0) THEN
          AVE = AVE/CNT
          DO ML = 1,MLON
              X(ML) = AVE
          END DO
      END IF

      RETURN
      END


module priors

	use utils1

contains

!=======================================================================
! Prior distribution functions: r is a uniform deviate from the unit
!
!

! Uniform[0:1]  ->  Delta[x1]

function DeltaFunctionPrior(r,x1,x2)

	implicit none

	double precision r,x1,x2,DeltaFunctionPrior

	DeltaFunctionPrior=x1

end function DeltaFunctionPrior

!=======================================================================
! Uniform[0:1]  ->  Uniform[x1:x2]

function UniformPrior(r,x1,x2)

      	implicit none

      	double precision r,x1,x2,UniformPrior

      	UniformPrior=x1+r*(x2-x1)

end function UniformPrior

!=======================================================================
! Uniform[0:1]  ->  LogUniform[x1:x2]

function LogPrior(r,x1,x2)

      	implicit none

      	double precision r,x1,x2,LogPrior
      	double precision lx1,lx2

      	if (r.le.0.0d0) then
       		LogPrior=-1.0d32
      	else
      	 	lx1=dlog10(x1)
       		lx2=dlog10(x2)
       		LogPrior=10.d0**(lx1+r*(lx2-lx1))
      	endif

end function LogPrior

!=======================================================================
! Uniform[0:1]  ->  Sin[x1:x2]  (angles in degrees):

function SinPrior(r,x1,x2)

      	implicit none

      	double precision r,x1,x2,SinPrior
      	real cx1,cx2,deg2rad
      	parameter(deg2rad=0.017453292)

      	cx1=cos(x1*deg2rad)
      	cx2=cos(x2*deg2rad)
      	SinPrior=1.d0*acos(cx1+r*(cx2-cx1))

end function SinPrior

!=======================================================================
! Uniform[0:1]  ->  Cauchy[mean=x0,FWHM=2*gamma]

function CauchyPrior(r,x0,gamma)

      	implicit none

      	double precision r,x0,gamma,CauchyPrior
      	real Pi
      	parameter(Pi=3.141592654)

      	CauchyPrior=x0+gamma*tan(Pi*(r-0.5))

end function CauchyPrior

!=======================================================================
! Uniform[0:1]  ->  Gaussian[mean=mu,variance=sigma**2]

function GaussianPrior(r,mu,sigma)

      	implicit none

      	double precision r,mu,sigma,GaussianPrior
      	double precision SqrtTwo
      	parameter(SqrtTwo=1.414213562d0)

      	if (r.le.1.0d-16.or.(1.0d0-r).le.1.0d-16) then
		GaussianPrior=-1.0d32
      	else
		GaussianPrior=mu+sigma*SqrtTwo*dierfc(2.d0*(1.d0-r))
      	endif

end function GaussianPrior

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

! Uniform[0:1]  ->  LogNormal[mode=a,width parameter=sigma]

function LogNormalPrior(r,a,sigma)

      	implicit none

      	double precision r,a,sigma,LogNormalPrior
      	double precision SqrtTwo,bracket
      	parameter(SqrtTwo=1.414213562d0)

      	bracket=sigma*sigma+sigma*SqrtTwo*dierfc(2.d0*r)
      	LogNormalPrior=a*dexp(bracket)

end function LogNormalPrior

!=======================================================================
! Inverse of complimentary error function in double precision

function dierfc(y)

	implicit none
      	double precision y,dierfc
      	double precision qa,qb,qc,qd,q0,q1,q2,q3,q4,pa,pb,p0,p1,p2,p3,p4,p5,p6,p7,p8,p9,p10,p11,p12,p13,p14,p15,p16,p17,p18
      	double precision p19,p20,p21,p22,x,z,w,u,s,t
      	double precision infinity
      	parameter (infinity=5.0d0)
      	parameter (qa=9.16461398268964d-01, &
      	qb=2.31729200323405d-01, &
      	qc=4.88826640273108d-01, &
      	qd=1.24610454613712d-01, &
      	q0=4.99999303439796d-01, &
      	q1=1.16065025341614d-01, &
      	q2=1.50689047360223d-01, &
      	q3=2.69999308670029d-01, &
      	q4=-7.28846765585675d-02)
      	parameter (pa=3.97886080735226000d+00, &
      	pb=1.20782237635245222d-01, &
      	p0=2.44044510593190935d-01, &
      	p1=4.34397492331430115d-01, &
      	p2=6.86265948274097816d-01, &
      	p3=9.56464974744799006d-01, &
      	p4=1.16374581931560831d+00, &
      	p5=1.21448730779995237d+00, &
      	p6=1.05375024970847138d+00, &
      	p7=7.13657635868730364d-01, &
      	p8=3.16847638520135944d-01, &
      	p9=1.47297938331485121d-02, &
      	p10=-1.05872177941595488d-01, &
      	p11=-7.43424357241784861d-02)
      	parameter (p12=2.20995927012179067d-03, &
      	p13=3.46494207789099922d-02, &
      	p14=1.42961988697898018d-02, &
      	p15=-1.18598117047771104d-02, &
      	p16=-1.12749169332504870d-02, &
      	p17=3.39721910367775861d-03, &
      	p18=6.85649426074558612d-03, &
      	p19=-7.71708358954120939d-04, &
      	p20=-3.51287146129100025d-03, &
      	p21=1.05739299623423047d-04, &
      	p22=1.12648096188977922d-03)
      	if (y==0.0) then
        	dierfc=infinity
		return
      	endif
      	z=y
      	if (y .gt. 1) z=2-y
      	w=qa-log(z)
      	u=sqrt(w)
      	s=(qc+log(u))/w
      	t=1/(u+qb)
      	x=u*(1-s*(0.5d0+s*qd))-((((q4*t+q3)*t+q2)*t+q1)*t+q0)*t
      	t=pa/(pa+x)
      	u=t-0.5d0
      	s=(((((((((p22*u+p21)*u+p20)*u+p19)*u+p18)*u+p17)*u+p16)*u+p15)*u+p14)*u+p13)*u+p12
      	s=((((((((((((s*u+p11)*u+p10)*u+p9)*u+p8)*u+p7)*u+p6)*u+p5)*u+p4)*u+p3)*u+p2) &
      	*u+p1)*u+p0)*t-z*exp(x*x-pb)
      	x=x+s*(1+x*s)
      	if (y .gt. 1) x=-x
      	dierfc=x

end function dierfc

!=======================================================================
end module priors


module initial_conditions

  use shared_data

  implicit none

  contains

  subroutine set_ic ! NB: nx, t_end etc is set in control.f90

    real(num) :: rho_lo
    real(num) :: rho_hi
    real(num) :: p0_lo
    real(num) :: fwtm, d
    real(num) :: y

    ! flow

    u = 0.0_num
    v = 0.0_num

    ! free to either set rho0, then get rho from it via
    !   rho(ix,iy = rho0(iy) + perturbation
    ! or set rho(ix,iy) then calc
    !   rho0(iy) =  1/Nx Sum_x (rho(ix,iy))
    !
    ! (i.e. user choice, all must be done in initial_conditions though)

    ! Simple case of unperturbed heavy on top of light (i.e. rho0(iy) = rho(:,iy) )

    rho_lo = 1.0_num
    rho_hi = 7.0_num
    d = x_max - x_min
    fwtm = 0.1_num *d

    do iy = -1, ny+2
      y = yc(iy)-0.5_num
      y = y * 1.818_num / fwtm
      rho0(iy) = rho_lo + 0.5_num * (rho_hi-rho_lo) * (1.0_num + tanh(y))
      rho(-1:nx+2,iy) = rho0(iy)
    enddo

    ! Calculate a HSE background pressure p0

    p0_lo = 10.0_num ! just sets a Gauge?
        ! However, due to p0^(<1) terms, cant tolerate a negative number in the profile
        ! so needs to be sufficiently high to not NAN the betas

    p0(-1) = p0_lo
    do iy = 0, ny+2
      p0(iy) = p0(iy-1) + 0.5_num * dy * (rho0(iy-1) + rho0(iy)) * grav_y
    enddo

  end subroutine set_ic

  subroutine shear_test_ic

    real(num) :: x,y, rho_s, delta_s

    rho_s = 42.0_num
    delta_s = 0.05_num

    do iy = -1,ny+1
    do ix = -1,nx+1
      x = xc(ix)
      y = yc(iy)
      if (y <= 0.5_num) then
        u(ix,iy) =  tanh(rho_s * (y-0.25_num))
      else
        u(ix,iy) = tanh(rho_s * (0.75_num -y))
      endif
      v(ix,iy) = delta_s * sin(2.0_num * pi * x)
    enddo
    enddo

    ! for homogeneous tests, should just be able to set background to uniform with
    ! an arbitary pressure

    rho = 1.0_num
    rho0 = 1.0_num
    p0 = 1.0_num

  end subroutine shear_test_ic

  subroutine minion_test_ic

    real(num) :: x,y

    do iy = -1,ny+1
    do ix = -1,nx+1
      x = xc(ix)
      y = yc(iy)
      u(ix,iy) = 1.0_num - 2.0_num * cos(2.0_num*pi*x)*sin(2.0_num*pi*y)
      v(ix,iy) = 1.0_num + 2.0_num * sin(2.0_num*pi*x)*cos(2.0_num*pi*y)
    enddo
    enddo

    do iy = 1, ny
    do ix = 1, nx
      divu(ix,iy) = (u(ix+1,iy) - u(ix-1,iy))/dx/2.0_num &
        & + (v(ix,iy+1) - v(ix,iy-1))/dy/2.0_num
    enddo
    enddo

    ! for homogeneous tests, should just be able to set background to uniform with
    ! an arbitary pressure

    rho = 1.0_num
    rho0 = 1.0_num
    p0 = 1.0_num

  end subroutine minion_test_ic

  subroutine vardens_adv_test_ic

    real(num) :: x,y,r

    u = 0.0_num
    v = 1.0_num

    rho = 1.0_num
    do iy = -1,ny+1
    do ix = -1,nx+1
      x = xc(ix)-0.5_num
      y = yc(iy)-0.5_num
      r = sqrt(x**2 + y**2)
      if (r <= 0.1_num) rho(ix,iy) = 2.0_num
    enddo
    enddo
    print *, 'rho on grid',sum(rho(1:nx,1:ny)*dx*dy)

    print *,'max numerical divu in ICs',maxval(abs(divu))
  end subroutine vardens_adv_test_ic

! rho0 now clashes with array for background rho - rewrite
  subroutine rti1_ic

    real(num) :: x, y
    real(num) :: d, rho_lo, rho_hi
    real(num) :: fwtm , amp
    real(num) :: p0_lo

    amp = 0.1_num

    d = x_max - x_min
    fwtm = 0.1_num *d
    rho_lo = 1.0_num
    rho_hi = 7.0_num

    u = 0.0_num
    v = 0.0_num

    rho = rho_lo

    do ix = -1, nx+1
    do iy = -1, ny+2
      x = xc(ix)

      !now overwrite rho with the perturbed + desingularised profile
      y = yc(iy) + amp * d * (cos(2.0_num * pi * x / d))
      y = y * 1.818_num / fwtm
      rho(ix,iy) = rho_lo + 0.5_num * (rho_hi-rho_lo) * (1.0_num + tanh(y))

    enddo
    enddo

  ! calculate a consistent rho0 and p0

    do iy = -1, ny+2
      rho0(iy) = sum(rho(1:nx,iy)) / REAL(nx,num)
    enddo

    ! Calculate a HSE background pressure p0

    p0_lo = 100.0_num ! just sets a Gauge?
        ! However, due to p0^(<1) terms, cant tolerate a negative number in the profile
        ! so needs to be sufficiently high to not NAN the betas

    p0(-1) = p0_lo
    do iy = 0, ny+2
      p0(iy) = p0(iy-1) + 0.5_num * dy * (rho0(iy-1) + rho0(iy)) * grav_y
    enddo

  end subroutine rti1_ic

  subroutine blob1_ic

    real(num) :: x,y,r
    real(num) :: p0_lo
    ! this should probabally be de-singularised with a tanh profile on rho=rho(r)

    u = 0.0_num
    v = 0.0_num

    grav_y = -1.0_num

    rho = 1.0_num

    do iy = -1,ny+1
    do ix = -1,nx+1
      x = xc(ix)-0.5_num
      y = yc(iy)-0.5_num
      r = sqrt(x**2 + y**2)
      if (r <= 0.1_num) rho(ix,iy) = 0.8_num
    enddo
    enddo

  ! calculate a consistent rho0 and p0

    do iy = -1, ny+2
      rho0(iy) = sum(rho(1:nx,iy)) / REAL(nx,num)
    enddo

    ! Calculate a HSE background pressure p0

    p0_lo = 100.0_num ! just sets a Gauge?
        ! However, due to p0^(<1) terms, cant tolerate a negative number in the profile
        ! so needs to be sufficiently high to not NAN the betas

    p0(-1) = p0_lo
    do iy = 0, ny+2
      p0(iy) = p0(iy-1) + 0.5_num * dy * (rho0(iy-1) + rho0(iy)) * grav_y
    enddo

    print *, 'rho on grid',sum(rho(1:nx,1:ny)*dx*dy)

  end subroutine blob1_ic

  subroutine circular_drop_ic

    real(num) :: x,y,r
    real(num) :: p0_lo

    u = 0.0_num
    v = 0.0_num

    grav_y = -1.0_num

    ! although I've said so in the wiki I don't think anything in the code
    ! requires definition that rho0 = lat avg rho at t=0
    ! rather, just that rho = rho0 + rho1 , p = p0 + p1, and that due to
    ! subtracting off the pressure grad and grav force associated with 0 quantities
    ! it follows that they are required to themselves be hydrostatically balanced

    ! ???

    ! therefore set the background state to be the uniform density upon which
    ! the (huge) perturbation sits

    rho0 = 1.0_num
    rho = 1.0_num !both should be same, i.e. initialise with no perturbation then add on top

    ! choose p0 s.t. this background is in HSE

    p0_lo = 10.0_num ! just sets a Gauge?
        ! However, due to p0^(<1) terms, cant tolerate a negative number in the profile
        ! so needs to be sufficiently high to not NAN the betas

    p0(-1) = p0_lo
    do iy = 0, ny+2
      p0(iy) = p0(iy-1) + 0.5_num * dy * (rho0(iy-1) + rho0(iy)) * grav_y
    enddo

    ! go through and add the (huge) perturbation to density

    do iy = -1,ny+1
    do ix = -1,nx+1
      x = xc(ix)-0.5_num
      y = yc(iy)-0.75_num
      r = sqrt(x**2 + y**2)
      if (r <= 0.15_num) rho(ix,iy) = 1000.0_num
    enddo
    enddo

    print *, 'rho on grid',sum(rho(1:nx,1:ny)*dx*dy)

  end subroutine circular_drop_ic

end module initial_conditions


! ****************************************************************************
! ... Mathematical utilitites
! ... COSMO Project
! ... Quim Ballabrera, March 2017
! ... About norm2: This has become a standard function after Fortran 2008.
! ****************************************************************************

module math

use types, only: dp
use constants, only: zero,one,nan
use utils

implicit none
private
public identity,akima,dakima,arange,mean,indexx,lookup_table, &
       avevar,rand,randn,randseed,eigencov,random_sample,svdcmp, &
       eigsort,matrinv
!public norm2

interface akima
  module procedure akimas,akimav
end interface akima

interface rand
  module procedure rand1,randm
end interface rand

interface randn
  module procedure randn1,randnm
end interface randn

contains
! ...
! =============================================================================
! ...
function akimas (x,f,xx) result(ff)

real(dp), dimension(:), intent(in)  :: x,f
real(dp), intent(in)                :: xx
real(dp)                            :: ff

! ... Local variables
! ...
real(dp) df(size(x))

df = dakima(x,f)
ff = evlak(xx,x,f,df)

end function akimas
! ...
! =============================================================================
! ...
function akimav (x,f,xx) result(ff)

real(dp), dimension(:), intent(in)  :: x,f
real(dp), dimension(:), intent(in)  :: xx
real(dp), dimension(size(xx))       :: ff

! ... Local variables
! ...
integer i,n,nn
real(dp) df(size(x))

n = size(x)
nn = size(xx)

df = dakima(x,f)
DO i=1,nn
  ff(i) = evlak(xx(i),x,f,df)
ENDDO

end function akimav
! ...
! =============================================================================
! ...
real(dp) function evlak(xc,x,f,df)
! ... Given a montone increasing array of x values (Note: routine does not
! ... check this), samples of values of the function f and 1st derivative
! ... df at the xs, interpolates by cubic polynomial.  The array df can be
! ... found by calling subroutine akima.
!
! ... If y falls outside the interval, the polynomial on the
! ... nearest interval is used to extrapolate.

real(dp), intent(in)                  :: xc
real(dp), dimension(:), INTENT(in)    :: x,f,df

! ... Local variables
! ...
integer k,n
integer init         ! Search for proper interval initiated at previous call
save init
data init/1/
real(dp) dx,t,s

n = size(x)

! ... Locate sample interval containing xc:  after xc lies in [x(init),
! ... x(init+1)), unless xc lies outside [x(1), x(n)] when the interval
! ... is the intervals containing the apprpriate end point.

init = min(init, n)
if (xc.gt.x(init)) then
  do k=init,n
    if (x(k).gt.xc) then
      init = k-1
      goto 1300
    endif
  enddo
  init = n-1
else
  do k=init,1,-1
    if (x(k).le.xc) then
      init = k
      goto 1300
    endif
  enddo
  init = 1
endif

1300 continue
dx = x(init+1) - x(init)

! ...  Evaluate the cubic interpolator
! ...
t = (xc - x(init))/dx
s = 1.0D0 - t
evlak = s**2*((1.0D0 + 2.0D0*t)*f(init)   + t*dx*df(init))   +     &
        t**2*((1.0D0 + 2.0D0*s)*f(init+1) - s*dx*df(init+1))
end function evlak
! ...
! =============================================================================
! ...
function dakima (x,f) result(df)
! ... Given the array of samples of a function f and sample points x,
! ... assumed to be monotone, generates slopes for an interpolating rule
! ... according to Akima's algorithm (Lancaster and Salkauskas,
! ... Curve and surface fitting, 1986 academic press, p 82).

real(dp), dimension(:), intent(in)  :: x,f
real(dp), dimension(size(x))        :: df

! ... Local variables
! ...
integer                             :: i,n
real(dp)                            :: Sn,eps,D1,D2
real(dp), DIMENSION(4)              :: S

n = size(x)
eps  = 1.0e-6*ABS(x(n) - x(1))

S(1) = (f(2) - f(1))/(x(2) - x(1))
S(2) = S(1)
S(3) = S(1)
S(4) = (f(3) - f(2))/(x(3) - x(2))
Sn   = (f(n) - f(n-1))/(x(n) - x(n-1))

do i=1, n
  D1 = abs(S(2) - S(1))
  D2 = abs(S(4) - S(3))
  df(i) = (D2*S(2) + D1*S(3))/(D1 + D2 + eps)

  S(1) = S(2)
  S(2) = S(3)
  S(3) = S(4)
  if (i+3.le.n) then
    S(4) = (f(i+3) - f(i+2))/(x(i+3)-x(i+2))
  else
    S(4) = Sn
  endif
enddo

if (n.eq.2) return

! ... If 3 or more points use gradient from a parabola for 1st & last df
! ...
df(1) = qakima(f(2)-f(1),x(2)-x(1),f(3)-f(1),x(3)-x(1))
df(n) = qakima(f(n-1)-f(n),x(n-1)-x(n),f(n-2)-f(n),x(n-2)-x(n))

contains
  real(dp) pure function qakima(u1,x1,u2,x2)
  real(dp), intent(in)       :: u1,x1,u2,x2
  qakima = (u1/x1**2-u2/x2**2)/(1.0_dp/x1-1.0_dp/x2)
  end function qakima

end function dakima
! ...
! =============================================================================
! ...
function arange(xo,xf,n)
! ... Returns the n-dimensional vector (xo,xo+dx,xo+2dx,...,xf)

integer, intent(in)     :: n
real(dp), intent(in)    :: xo,xf
real(dp), dimension(n)  :: arange

! ... Local variables
! ...
integer i
real(dp) dx

dx = (xf-xo)/(n-1)
do i=1,n
  arange(i) = (i-1)*dx + xo
enddo

end function arange
! ...
! =============================================================================
! ...
function identity(n)
! ... Returns the (n x n) identity matrix

integer, intent(in)          :: n
real(dp), dimension(n,n)     :: identity

! ... Local variables
! ...
integer i

identity = zero
do i=1,n
  identity(i,i) = one
enddo

end function identity
! ...
! =============================================================================
! ...
real(dp) function mean(A,W)
! ... Calculates the weighted mean = 1/N * Sum W(i)*A(i)
! ... Weights are optional.

real(dp), dimension(:), intent(in)     :: A
real(dp), dimension(:), optional       :: W

integer n
real(dp) Sw

mean = nan
n = size(A)
if (n.eq.0) return

if (present(W)) then
  Sw   = sum(W)
  mean = dot_product(W,A)/Sw
else
  mean = sum(A)/N
endif

end function mean
! ...
! =============================================================================
! ...
subroutine avevar (A,ave,var)

real(dp), dimension(:), intent(in)   :: A
real(dp), intent(out)                :: ave,var

! ... Local variables:
! ...
integer j,n
real(dp) s,ep

ave = nan
var = nan
n = size(A)
if (n.eq.0) return

ave = sum(A(1:n))/n

var = 0.0d0
ep  = 0.0d0
do j=1,n
  s   = A(j) - ave
  ep  = ep + s
  var = var + s*s
enddo
var = (var-ep**2/n)/(n-1)

return
end
!  (C) Copr. 1986-92 Numerical Recipes Software *5sV1.
! ...
! =============================================================================
! ...
!real(dp) function norm2(A)
! ... Calculates the weighted mean = 1/N * Sum W(i)*A(i)
! ... Weights are optional.

!real(dp), dimension(:), intent(in)     :: A

!norm2 = sqrt(dot_product(A,A))

!end function norm2
! ...
! =============================================================================
! ...
! ... Subroutine indexx from Numerical Recipes in Fortran.
! ... The Art of Scientific Computing. Press et al., 1992.
! ...
      subroutine indexx(arr,indx)

      real(dp), dimension(:), intent(in)          :: arr
      integer, dimension(size(arr)), intent(out)  :: indx

      ! ... Local varibles:
      ! ...
      integer, parameter                          :: M=7
      INTEGER                                     :: n,i,indxt,ir,itemp,j,jstack,k,l
      INTEGER, dimension(size(arr))               :: istack
      real(dp)                                    :: a

      n = size(arr)

      do j=1,n
        indx(j)=j
      enddo

      jstack=0
      l=1
      ir=n
1     if(ir-l.lt.M)then
        do j=l+1,ir
          indxt=indx(j)
          a=arr(indxt)
          do i=j-1,1,-1
            if(arr(indx(i)).le.a) goto 2
            indx(i+1)=indx(i)
          enddo
          i=0
2         indx(i+1)=indxt
        enddo
        if(jstack.eq.0)return
        ir=istack(jstack)
        l=istack(jstack-1)
        jstack=jstack-2
      else
        k=(l+ir)/2
        itemp=indx(k)
        indx(k)=indx(l+1)
        indx(l+1)=itemp
        if(arr(indx(l+1)).gt.arr(indx(ir)))then
          itemp=indx(l+1)
          indx(l+1)=indx(ir)
          indx(ir)=itemp
        endif
        if(arr(indx(l)).gt.arr(indx(ir)))then
          itemp=indx(l)
          indx(l)=indx(ir)
          indx(ir)=itemp
        endif
        if(arr(indx(l+1)).gt.arr(indx(l)))then
          itemp=indx(l+1)
          indx(l+1)=indx(l)
          indx(l)=itemp
        endif
        i=l+1
        j=ir
        indxt=indx(l)
        a=arr(indxt)
3       continue
          i=i+1
        if(arr(indx(i)).lt.a)goto 3
4       continue
          j=j-1
        if(arr(indx(j)).gt.a)goto 4
        if(j.lt.i)goto 5
        itemp=indx(i)
        indx(i)=indx(j)
        indx(j)=itemp
        goto 3
5       indx(l)=indx(j)
        indx(j)=indxt
        jstack=jstack+2
        if(ir-i+1.ge.j-l)then
          istack(jstack)=ir
          istack(jstack-1)=i
          ir=j-1
        else
          istack(jstack)=j-1
          istack(jstack-1)=l
          l=i
        endif
      endif
      goto 1
      end subroutine indexx
!  (C) Copr. 1986-92 Numerical Recipes Software *5sV1.
! ...
! =============================================================================
! ...
  real(dp) function lookup_table (x,f,xo) result(fo)

  real(dp), dimension(:), intent(in)        :: x
  real(dp), dimension(:), intent(in)        :: f
  real(dp), intent(in)                      :: xo

  integer i1,i2,n

  n = size(x)

  if (x(1).lt.x(n)) then
    ! ... Ordered in ascending order
    if (xo.le.x(1)) then
      fo = f(1)
      return
    else if (xo.ge.x(n)) then
      fo = f(n)
    else
      i1 = locate(x(1:n),xo)
      i2 = i1 + 1
      fo = f(i1) + (xo-x(i1))/(x(i2)-x(i1))*(f(i2)-f(i1))
    endif
  else
    ! ... Ordered in descending order
    if (xo.ge.x(1)) then
      fo = f(1)
      return
    else if (xo.le.x(n)) then
      fo = f(n)
    else
      i1 = locate(x(1:n),xo)
      i2 = i1 + 1
      fo = f(i1) + (xo-x(i1))/(x(i2)-x(i1))*(f(i2)-f(i1))
    endif
  endif

  end function lookup_table
! ...
! =============================================================================
! ...
function rand1 ()

real(dp)                                   :: rand1

call random_number(rand1)  ! GNU RANDOM GENERATOR

end function rand1
! ...
! =============================================================================
! ...
function randm (m) result(ff)

integer, intent(in)                        :: m
real(dp), dimension(m)                     :: ff

call random_number(ff)  ! GNU RANDOM GENERATOR

end function randm
! ...
! ========================================================================
! ...
function randn1 ()

real(dp)                                   :: randn1

! ... Local variables
! ...
real(dp), dimension(1)                     :: ff

ff = randnm(1)
randn1 = ff(1)

end function randn1
! ...
! ========================================================================
! ...
function randnm (m) result(ff)

integer, intent(in)                        :: m
real(dp), dimension(m)                     :: ff

! ... Local variables
! ...
integer i
reaL(dp), parameter                    :: s  =  0.449871D0
real(dp), parameter                    :: t  = -0.386595D0
real(dp), parameter                    :: a  =  0.19600D0
real(dp), parameter                    :: b  =  0.25472D0
real(dp), parameter                    :: r1 =  0.27597D0
real(dp), parameter                    :: r2 =  0.27846D0
real(dp) u,v,x,y,q

do i=1,m

  do
    call random_number(u)  ! GNU RANDOM GENERATOR
    call random_number(v)  ! GNU RANDOM GENERATOR
    v = 1.7156D0 * (v - 0.5D0)

    ! ... Evaluate the quadratic form
    ! ...
    x = u - s
    y = abs(v) - t
    q = x**2 + y*(a*y - b*x)

    if (q .lt. r1) exit
    if (q .gt. r2) cycle
    if (v**2 .LT. -4D0*LOG(u)*u**2) exiT
  enddo
  ff(i) = v/u

enddo

end function randnm
! ...
! =============================================================================
! ...
subroutine randseed(idum)

integer, intent(in)                    :: idum

integer                                :: n
integer, dimension(:), allocatable     :: rseed

! ... Random seed
! ...
call random_seed(size=n)
allocate(rseed(n))
rseed(:) = idum
call random_seed(put=rseed)

end subroutine randseed
! ...
! =============================================================================
! ...
function random_sample (N,io,if) result(ff)

! ... Samples randomly the segment [io,if].
! ... N samples. The values of the sample are in random_sample(1:N).
! ...
integer, intent(in)                   :: N
integer, intent(in), OPTIONAL         :: io,if
integer, dimension(N)                 :: ff

integer i,il,lio,lif
real(dp) nn(1)

if (PRESENT(io)) then
  lio = io
else
  lio = 1
endif

if (PRESENT(if)) then
  lif = if
else
  lif = N
endif

il = lif - lio + 1
do i=1,N
  ff(i) = INT( io+il*rand1() )
enddo

RETURN
end function random_sample
! ...
! =============================================================================
! ...
! ***************************************************************************
! ... eigencov.f90
! ... Eigenvectors and eigenvalues of a covariance (square, symmetric) matrix.
! ...
! ... Input:
! ... N = Dimension of the P(N,N) matrix
! ... P = Input covariance matrix
! ... Output
! ... U = Eigenvectors (N,N)
! ... D = Eigenvalues (N)
! ... rank = integer with the number of non-zero eigenvalues.
! ...
! ... Uses routines tred2, tqli, and eigsort of the Numerical Recipes.
! ===========================================================================
! ...
subroutine eigencov (N,P,U,D,rank,verbose)

implicit none

INTEGER N,rank
REAL(dp) P(N,N),U(N,N)
REAL(dp) D(N)
logical verbose

INTEGER i,k
REAL(dp) xsum
REAL(dp) E(N)

if (verbose) then
  xsum = 0.0D0
  DO i=1,n
    xsum = xsum + P(i,i)
  ENDDO
  WRITE(6,*) 'Trace covariance matrix : ', xsum
endif

U = P

CALL tred2 (U,n,n,D,E)
CALL tqli (D,E,n,n,U)

DO i=1,n
  IF(D(i).LT.0.0) D(i) = 0.0D0
ENDDO

CALL eigsort(D,n,U,n)

rank = COUNT(D.NE.0)

if (verbose) then
  xsum = 0.0D0
  DO i=1,n
  DO k=1,rank
    xsum = xsum + D(k)*U(i,k)*U(i,k)
  ENDDO
  ENDDO
  WRITE(6,*) '>> TEST: Trace covariance matrix : ', xsum
  WRITE(6,*) '>> using rank: ', rank
endif

RETURN
END
! ...
! ========================================================================
! ...
      SUBROUTINE tred2(a,n,np,d,e)
      INTEGER n,np
      DOUBLE PRECISION a(np,np),d(np),e(np)
      INTEGER i,j,k,l
      DOUBLE PRECISION f,g,h,hh,scale
      do 18 i=n,2,-1
        l=i-1
        h=0.d0
        scale=0.d0
        if(l.gt.1)then
          do 11 k=1,l
            scale=scale+abs(a(i,k))
11        continue
          if(scale.eq.0.d0)then
            e(i)=a(i,l)
          else
            do 12 k=1,l
              a(i,k)=a(i,k)/scale
              h=h+a(i,k)**2
12          continue
            f=a(i,l)
            g=-sign(sqrt(h),f)
            e(i)=scale*g
            h=h-f*g
            a(i,l)=f-g
            f=0.d0
            do 15 j=1,l
!     Omit following line if finding only eigenvalues
              a(j,i)=a(i,j)/h
              g=0.d0
              do 13 k=1,j
                g=g+a(j,k)*a(i,k)
13            continue
              do 14 k=j+1,l
                g=g+a(k,j)*a(i,k)
14            continue
              e(j)=g/h
              f=f+e(j)*a(i,j)
15          continue
            hh=f/(h+h)
            do 17 j=1,l
              f=a(i,j)
              g=e(j)-hh*f
              e(j)=g
              do 16 k=1,j
                a(j,k)=a(j,k)-f*e(k)-g*a(i,k)
16            continue
17          continue
          endif
        else
          e(i)=a(i,l)
        endif
        d(i)=h
18    continue
!     Omit following line if finding only eigenvalues.
      d(1)=0.d0
      e(1)=0.d0
      do 24 i=1,n
!     Delete lines from here ...
        l=i-1
        if(d(i).ne.0.d0)then
          do 22 j=1,l
            g=0.d0
            do 19 k=1,l
              g=g+a(i,k)*a(k,j)
19          continue
            do 21 k=1,l
              a(k,j)=a(k,j)-g*a(k,i)
21          continue
22        continue
        endif
!     ... to here when finding only eigenvalues.
        d(i)=a(i,i)
!     Also delete lines from here ...
        a(i,i)=1.d0
        do 23 j=1,l
          a(i,j)=0.d0
          a(j,i)=0.d0
23      continue
!     ... to here when finding only eigenvalues.
24    continue
      return
      END
!  (C) Copr. 1986-92 Numerical Recipes Software *5sV1.
! ...
! ========================================================================
! ...
      SUBROUTINE tqli(d,e,n,np,z)
      INTEGER n,np
      DOUBLE PRECISION d(np),e(np),z(np,np)
!CU    USES pythag
      INTEGER i,iter,k,l,m
      DOUBLE PRECISION b,c,dd,f,g,p,r,s
      do 11 i=2,n
        e(i-1)=e(i)
11    continue
      e(n)=0.d0
      do 15 l=1,n
        iter=0
1       do 12 m=l,n-1
          dd=abs(d(m))+abs(d(m+1))
          if (abs(e(m))+dd.eq.dd) goto 2
12      continue
        m=n
2       if(m.ne.l)then
          if(iter.eq.40) STOP 'too many iterations in tqli'
          iter=iter+1
          g=(d(l+1)-d(l))/(2.d0*e(l))
          r=pythag(g,1.d0)
          g=d(m)-d(l)+e(l)/(g+sign(r,g))
          s=1.d0
          c=1.d0
          p=0.d0
          do 14 i=m-1,l,-1
            f=s*e(i)
            b=c*e(i)
            r=pythag(f,g)
            e(i+1)=r
            if(r.eq.0.d0)then
              d(i+1)=d(i+1)-p
              e(m)=0.d0
              goto 1
            endif
            s=f/r
            c=g/r
            g=d(i+1)-p
            r=(d(i)-g)*s+2.d0*c*b
            p=s*r
            d(i+1)=g+p
            g=c*r-b
!     Omit lines from here ...
            do 13 k=1,n
              f=z(k,i+1)
              z(k,i+1)=s*z(k,i)+c*f
              z(k,i)=c*z(k,i)-s*f
13          continue
!     ... to here when finding only eigenvalues.
14        continue
          d(l)=d(l)-p
          e(l)=g
          e(m)=0.d0
          goto 1
        endif
15    continue
      return
      END
!  (C) Copr. 1986-92 Numerical Recipes Software *5sV1.
! ...
! =====================================================================
! ...
subroutine eigsort(d,r,v,n)

implicit none

integer, intent(in)                       :: n,r
real(dp), dimension(r), intent(inout)     :: d
real(dp), dimension(n,r), intent(inout)   :: v

! ... Local variables
! ...
integer i,j,k
real(dp) p

do i=1,r-1
  k=i
  p=d(i)
  do j=i+1,r
    if (d(j).ge.p) then
      k=j
      p=d(j)
    endif
  enddo
  if (k.ne.i) then
    d(k)=d(i)
    d(i)=p
    do j=1,n
      p=v(j,i)
      v(j,i)=v(j,k)
      v(j,k)=p
    enddo
  endif
enddo

return
end subroutine eigsort
! ...
! =============================================================================
! ...
real(dp) pure function pythag(a,b)

implicit none

real(dp), intent(in)                    :: a,b

! ... Local variables
! ...
real(dp) absa,absb

absa=abs(a)
absb=abs(b)
if(absa.gt.absb)then
  pythag=absa*sqrt(1.d0+(absb/absa)**2)
else
  if(absb.eq.0.d0)then
    pythag=0.d0
  else
    pythag=absb*sqrt(1.d0+(absa/absb)**2)
  endif
endif
return
end function pythag
!  (C) Copr. 1986-92 Numerical Recipes Software *5sV1.
! ...
! =============================================================================
! ...
      SUBROUTINE svdcmp(a,m,n,mp,np,w,v)

      implicit none

      integer m,mp,n,np
      real(dp) a(mp,np),v(np,np),w(np)
!CU    USES pythag
      integer i,its,j,jj,k,l,nm
      real(dp) anorm,c,f,g,h,s,scale,x,y,z,rv1(n)

      g=0.0d0
      scale=0.0d0
      anorm=0.0d0
      do 25 i=1,n
        l=i+1
        rv1(i)=scale*g
        g=0.0d0
        s=0.0d0
        scale=0.0d0
        if(i.le.m)then
          do 11 k=i,m
            scale=scale+abs(a(k,i))
11        continue
          if(scale.ne.0.0d0)then
            do 12 k=i,m
              a(k,i)=a(k,i)/scale
              s=s+a(k,i)*a(k,i)
12          continue
            f=a(i,i)
            g=-sign(sqrt(s),f)
            h=f*g-s
            a(i,i)=f-g
            do 15 j=l,n
              s=0.0d0
              do 13 k=i,m
                s=s+a(k,i)*a(k,j)
13            continue
              f=s/h
              do 14 k=i,m
                a(k,j)=a(k,j)+f*a(k,i)
14            continue
15          continue
            do 16 k=i,m
              a(k,i)=scale*a(k,i)
16          continue
          endif
        endif
        w(i)=scale *g
        g=0.0d0
        s=0.0d0
        scale=0.0d0
        if((i.le.m).and.(i.ne.n))then
          do 17 k=l,n
            scale=scale+abs(a(i,k))
17        continue
          if(scale.ne.0.0d0)then
            do 18 k=l,n
              a(i,k)=a(i,k)/scale
              s=s+a(i,k)*a(i,k)
18          continue
            f=a(i,l)
            g=-sign(sqrt(s),f)
            h=f*g-s
            a(i,l)=f-g
            do 19 k=l,n
              rv1(k)=a(i,k)/h
19          continue
            do 23 j=l,m
              s=0.0d0
              do 21 k=l,n
                s=s+a(j,k)*a(i,k)
21            continue
              do 22 k=l,n
                a(j,k)=a(j,k)+s*rv1(k)
22            continue
23          continue
            do 24 k=l,n
              a(i,k)=scale*a(i,k)
24          continue
          endif
        endif
        anorm=max(anorm,(abs(w(i))+abs(rv1(i))))
25    continue
      do 32 i=n,1,-1
        if(i.lt.n)then
          if(g.ne.0.0d0)then
            do 26 j=l,n
              v(j,i)=(a(i,j)/a(i,l))/g
26          continue
            do 29 j=l,n
              s=0.0d0
              do 27 k=l,n
                s=s+a(i,k)*v(k,j)
27            continue
              do 28 k=l,n
                v(k,j)=v(k,j)+s*v(k,i)
28            continue
29          continue
          endif
          do 31 j=l,n
            v(i,j)=0.0d0
            v(j,i)=0.0d0
31        continue
        endif
        v(i,i)=1.0d0
        g=rv1(i)
        l=i
32    continue
      do 39 i=min(m,n),1,-1
        l=i+1
        g=w(i)
        do 33 j=l,n
          a(i,j)=0.0d0
33      continue
        if(g.ne.0.0d0)then
          g=1.0d0/g
          do 36 j=l,n
            s=0.0d0
            do 34 k=l,m
              s=s+a(k,i)*a(k,j)
34          continue
            f=(s/a(i,i))*g
            do 35 k=i,m
              a(k,j)=a(k,j)+f*a(k,i)
35          continue
36        continue
          do 37 j=i,m
            a(j,i)=a(j,i)*g
37        continue
        else
          do 38 j= i,m
            a(j,i)=0.0d0
38        continue
        endif
        a(i,i)=a(i,i)+1.0d0
39    continue
      do 49 k=n,1,-1
        do 48 its=1,30
          do 41 l=k,1,-1
            nm=l-1
            if((abs(rv1(l))+anorm).eq.anorm)  goto 2
            if((abs(w(nm))+anorm).eq.anorm)  goto 1
41        continue
1         c=0.0d0
          s=1.0d0
          do 43 i=l,k
            f=s*rv1(i)
            rv1(i)=c*rv1(i)
            if((abs(f)+anorm).eq.anorm) goto 2
            g=w(i)
            h=pythag(f,g)
            w(i)=h
            h=1.0d0/h
            c= (g*h)
            s=-(f*h)
            do 42 j=1,m
              y=a(j,nm)
              z=a(j,i)
              a(j,nm)=(y*c)+(z*s)
              a(j,i)=-(y*s)+(z*c)
42          continue
43        continue
2         z=w(k)
          if(l.eq.k)then
            if(z.lt.0.0d0)then
              w(k)=-z
              do 44 j=1,n
                v(j,k)=-v(j,k)
44            continue
            endif
            goto 3
          endif
          if(its.eq.30) stop  'no convergence in svdcmp'
          x=w(l)
          nm=k-1
          y=w(nm)
          g=rv1(nm)
          h=rv1(k)
          f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0d0*h*y)
          g=pythag(f,1.0d0)
          f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x
          c=1.0d0
          s=1.0d0
          do 47 j=l,nm
            i=j+1
            g=rv1(i)
            y=w(i)
            h=s*g
            g=c*g
            z=pythag(f,h)
            rv1(j)=z
            c=f/z
            s=h/z
            f= (x*c)+(g*s)
            g=-(x*s)+(g*c)
            h=y*s
            y=y*c
            do 45 jj=1,n
              x=v(jj,j)
              z=v(jj,i)
              v(jj,j)= (x*c)+(z*s)
              v(jj,i)=-(x*s)+(z*c)
45          continue
            z=pythag(f,h)
            w(j)=z
            if(z.ne.0.0d0)then
              z=1.0d0/z
              c=f*z
              s=h*z
            endif
            f= (c*g)+(s*y)
            x=-(s*g)+(c*y)
            do 46 jj=1,m
              y=a(jj,j)
              z=a(jj,i)
              a(jj,j)= (y*c)+(z*s)
              a(jj,i)=-(y*s)+(z*c)
46          continue
47        continue
          rv1(l)=0.0d0
          rv1(k)=f
          w(k)=x
48      continue
3       continue
49    continue
      return
      end subroutine svdcmp
!C  (C) Copr. 1986-92 Numerical Recipes Software *5sV1.
! ...
! =============================================================================
! ...
subroutine matrinv (N,A,Y)

implicit none

integer, intent(in)                        :: N
REAL(dp), dimension(N,N), intent(in)       :: A
REAL(dp), dimension(N,N), intent(out)      :: Y

integer i,j
integer, DIMENSION (N)                     :: indx
REAL(dp) D
REAL(dp), DIMENSION (N,N)                  :: AA

! ... Saving matrix
! ...
AA = A

Y(:,:) = 0.0D0
DO i=1,N
  Y(i,i) = 1.0D0
ENDDO

call ludcmp (AA,N,N,INDX,D)

do j=1,N
  calL lubksb (AA,N,N,INDX,Y(1,j))
enddo

RETURN
END SUBROUTINE matrinv
! ...
! ================================================================================
! ...
subroutine ludcmp(a,n,np,indx,d)

implicit none

real(dp), parameter                           :: TINY=1.0D-20

integer, intent(in)                           :: n,np
real(dp), dimension(np,np), intent(inout)     :: a
integer, dimension(n), intent(out)            :: indx
real(dp), intent(out)                         :: d

! ... Local variables
! ...
integer i,imax,j,k
real(dp) aamax,dum,sum,vv(n)

d = 1.d0
do i=1,n
  aamax = 0.d0
  do j=1,n
    if (abs(a(i,j)).gt.aamax) aamax = abs(a(i,j))
  enddo
  if (aamax.eq.0.d0) stop  'singular matrix in ludcmp'
  vv(i) = 1.d0/aamax
enddo

do j=1,n
  do i=1,j-1
    sum = a(i,j)
    do k=1,i-1
      sum = sum - a(i,k)*a(k,j)
    enddo
    a(i,j) = sum
  enddo
  aamax = 0.d0
  do i=j,n
    sum = a(i,j)
    do k=1,j-1
      sum = sum-a(i,k)*a(k,j)
    enddo
    a(i,j) = sum
    dum = vv(i)*abs(sum)
    if (dum.ge.aamax) then
      imax  = i
      aamax = dum
    endif
  enddo
  if (j.ne.imax)then
    do k=1,n
      dum       = a(imax,k)
      a(imax,k) = a(j,k)
      a(j,k)    = dum
    enddo
    d = -d
    vv(imax) = vv(j)
  endif
  indx(j) = imax
  if(a(j,j).eq.0.d0) a(j,j) = TINY
  if(j.ne.n)then
    dum = 1.d0/a(j,j)
    do i=j+1,n
      a(i,j) = a(i,j)*dum
    enddo
  endif
enddo

return
end subroutine ludcmp
!C  (C) Copr. 1986-92 Numerical Recipes Software *5sV1.
! ...
! ================================================================================
! ...
subroutine lubksb(a,n,np,indx,b)

implicit none

integer, intent(in)                    :: n,np
integer, dimension(n), intent(in)      :: indx
real(dp), dimension(np,np), intent(in) :: a
real(dp), dimension(n), intent(out)    :: b

! ... Local variables
! ...
integer i,ii,j,ll
real(dp) sum

ii=0
do i=1,n
  ll=indx(i)
  sum=b(ll)
  b(ll)=b(i)
  if (ii.ne.0)then
    do j=ii,i-1
      sum=sum-a(i,j)*b(j)
    enddo
  else if (sum.ne.0.d0) then
    ii=i
  endif
  b(i)=sum
enddo
do i=n,1,-1
  sum=b(i)
  do j=i+1,n
    sum=sum-a(i,j)*b(j)
  enddo
  b(i)=sum/a(i,i)
enddo
return
end subroutine lubksb
!  (C) Copr. 1986-92 Numerical Recipes Software *5sV1.

end module math


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

      subroutine setcoeff

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

      implicit none

      include 'applu.incl'

c---------------------------------------------------------------------
c  local variables
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c   set up coefficients
c---------------------------------------------------------------------
      dxi = 1.0d+00 / ( nx0 - 1 )
      deta = 1.0d+00 / ( ny0 - 1 )
      dzeta = 1.0d+00 / ( nz0 - 1 )

      tx1 = 1.0d+00 / ( dxi * dxi )
      tx2 = 1.0d+00 / ( 2.0d+00 * dxi )
      tx3 = 1.0d+00 / dxi

      ty1 = 1.0d+00 / ( deta * deta )
      ty2 = 1.0d+00 / ( 2.0d+00 * deta )
      ty3 = 1.0d+00 / deta

      tz1 = 1.0d+00 / ( dzeta * dzeta )
      tz2 = 1.0d+00 / ( 2.0d+00 * dzeta )
      tz3 = 1.0d+00 / dzeta

c---------------------------------------------------------------------
c   diffusion coefficients
c---------------------------------------------------------------------
      dx1 = 0.75d+00
      dx2 = dx1
      dx3 = dx1
      dx4 = dx1
      dx5 = dx1

      dy1 = 0.75d+00
      dy2 = dy1
      dy3 = dy1
      dy4 = dy1
      dy5 = dy1

      dz1 = 1.00d+00
      dz2 = dz1
      dz3 = dz1
      dz4 = dz1
      dz5 = dz1

c---------------------------------------------------------------------
c   fourth difference dissipation
c---------------------------------------------------------------------
      dssp = ( max (dx1, dy1, dz1 ) ) / 4.0d+00

c---------------------------------------------------------------------
c   coefficients of the exact solution to the first pde
c---------------------------------------------------------------------
      ce(1,1) = 2.0d+00
      ce(1,2) = 0.0d+00
      ce(1,3) = 0.0d+00
      ce(1,4) = 4.0d+00
      ce(1,5) = 5.0d+00
      ce(1,6) = 3.0d+00
      ce(1,7) = 5.0d-01
      ce(1,8) = 2.0d-02
      ce(1,9) = 1.0d-02
      ce(1,10) = 3.0d-02
      ce(1,11) = 5.0d-01
      ce(1,12) = 4.0d-01
      ce(1,13) = 3.0d-01

c---------------------------------------------------------------------
c   coefficients of the exact solution to the second pde
c---------------------------------------------------------------------
      ce(2,1) = 1.0d+00
      ce(2,2) = 0.0d+00
      ce(2,3) = 0.0d+00
      ce(2,4) = 0.0d+00
      ce(2,5) = 1.0d+00
      ce(2,6) = 2.0d+00
      ce(2,7) = 3.0d+00
      ce(2,8) = 1.0d-02
      ce(2,9) = 3.0d-02
      ce(2,10) = 2.0d-02
      ce(2,11) = 4.0d-01
      ce(2,12) = 3.0d-01
      ce(2,13) = 5.0d-01

c---------------------------------------------------------------------
c   coefficients of the exact solution to the third pde
c---------------------------------------------------------------------
      ce(3,1) = 2.0d+00
      ce(3,2) = 2.0d+00
      ce(3,3) = 0.0d+00
      ce(3,4) = 0.0d+00
      ce(3,5) = 0.0d+00
      ce(3,6) = 2.0d+00
      ce(3,7) = 3.0d+00
      ce(3,8) = 4.0d-02
      ce(3,9) = 3.0d-02
      ce(3,10) = 5.0d-02
      ce(3,11) = 3.0d-01
      ce(3,12) = 5.0d-01
      ce(3,13) = 4.0d-01

c---------------------------------------------------------------------
c   coefficients of the exact solution to the fourth pde
c---------------------------------------------------------------------
      ce(4,1) = 2.0d+00
      ce(4,2) = 2.0d+00
      ce(4,3) = 0.0d+00
      ce(4,4) = 0.0d+00
      ce(4,5) = 0.0d+00
      ce(4,6) = 2.0d+00
      ce(4,7) = 3.0d+00
      ce(4,8) = 3.0d-02
      ce(4,9) = 5.0d-02
      ce(4,10) = 4.0d-02
      ce(4,11) = 2.0d-01
      ce(4,12) = 1.0d-01
      ce(4,13) = 3.0d-01

c---------------------------------------------------------------------
c   coefficients of the exact solution to the fifth pde
c---------------------------------------------------------------------
      ce(5,1) = 5.0d+00
      ce(5,2) = 4.0d+00
      ce(5,3) = 3.0d+00
      ce(5,4) = 2.0d+00
      ce(5,5) = 1.0d-01
      ce(5,6) = 4.0d-01
      ce(5,7) = 3.0d-01
      ce(5,8) = 5.0d-02
      ce(5,9) = 4.0d-02
      ce(5,10) = 3.0d-02
      ce(5,11) = 1.0d-01
      ce(5,12) = 3.0d-01
      ce(5,13) = 2.0d-01

      return
      end