      SUBROUTINE PCSDPSUBTST( WKNOWN, UPLO, N, THRESH, ABSTOL, A, COPYA,
     $                        Z, IA, JA, DESCA, WIN, WNEW, IPREPAD,
     $                        IPOSTPAD, WORK, LWORK, RWORK, LRWORK,
     $                        LWORK1, IWORK, LIWORK, RESULT, TSTNRM,
     $                        QTQNRM, NOUT )
*
*  -- ScaLAPACK testing routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     February 28, 2000
*
*     .. Scalar Arguments ..
      LOGICAL            WKNOWN
      CHARACTER          UPLO
      INTEGER            IA, IPOSTPAD, IPREPAD, JA, LIWORK, LRWORK,
     $                   LWORK, LWORK1, N, NOUT, RESULT
      REAL               ABSTOL, QTQNRM, THRESH, TSTNRM
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * ), IWORK( * )
      REAL               RWORK( * ), WIN( * ), WNEW( * )
      COMPLEX            A( * ), COPYA( * ), WORK( * ), Z( * )
*     ..
*
*  Purpose
*  =======
*
*  PCSDPSUBTST calls PCHEEVD and then tests the output of
*  PCHEEVD
*  If JOBZ = 'V' then the following two tests are performed:
*     |AQ -QL| / (abstol + eps * norm(A) ) < N*THRESH
*     |QT * Q - I| / eps * norm(A) < N*THRESH
*  If WKNOWN then
*     we check to make sure that the eigenvalues match expectations
*     i.e. |WIN - WNEW(1+IPREPAD)| / (eps * |WIN|) < THRESH
*     where WIN is the array of eigenvalues as computed by
*     PCHEEVD when eigenvectors are requested
*
*  Arguments
*  =========
*
*     NP = the number of rows local to a given process.
*     NQ = the number of columns local to a given process.
*
*  WKNOWN  (global input) INTEGER
*          .FALSE.:  WIN does not contain the eigenvalues
*          .TRUE.:   WIN does contain the eigenvalues
*
*  UPLO    (global input) CHARACTER*1
*          Specifies whether the upper or lower triangular part of the
*          Hermitian matrix A is stored:
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  N       (global input) INTEGER
*          Size of the matrix to be tested.  (global size)
*
*  THRESH  (global input) REAL
*          A test will count as "failed" if the "error", computed as
*          described below, exceeds THRESH.  Note that the error
*          is scaled to be O(1), so THRESH should be a reasonably
*          small multiple of 1, e.g., 10 or 100.  In particular,
*          it should not depend on the precision (single vs. double)
*          or the size of the matrix.  It must be at least zero.
*
*  ABSTOL  (global input) REAL
*          The absolute tolerance for the eigenvalues. An
*          eigenvalue is considered to be located if it has
*          been determined to lie in an interval whose width
*          is "abstol" or less. If "abstol" is less than or equal
*          to zero, then ulp*|T| will be used, where |T| is
*          the 1-norm of the matrix. If eigenvectors are
*          desired later by inverse iteration ("PCSTEIN"),
*          "abstol" MUST NOT be bigger than ulp*|T|.
*
*  A       (local workspace) COMPLEX array
*          global dimension (N, N), local dimension (DESCA(DLEN_), NQ)
*            A is distributed in a block cyclic manner over both rows
*            and columns.
*            See PCHEEVD for a description of block cyclic layout.
*          The test matrix, which is then modified by PCHEEVD
*          A has already been padded front and back, use A(1+IPREPAD)
*
*  COPYA   (local input) COMPLEX array, dimension(N*N)
*          COPYA holds a copy of the original matrix A
*          identical in both form and content to A
*
*  Z       (local workspace) COMPLEX array, dim (N*N)
*          Z is distributed in the same manner as A
*          Z contains the eigenvector matrix
*          Z is used as workspace by the test routines
*          PCSEPCHK and PCSEPQTQ.
*          Z has already been padded front and back, use Z(1+IPREPAD)
*
*  IA      (global input) INTEGER
*          On entry, IA specifies the global row index of the submatrix
*          of the global matrix A, COPYA and Z to operate on.
*
*  JA      (global input) INTEGER
*          On entry, IA specifies the global column index of the submat
*          of the global matrix A, COPYA and Z to operate on.
*
*  DESCA   (global/local input) INTEGER array of dimension 8
*          The array descriptor for the matrix A, COPYA and Z.
*
*  WIN     (global input) REAL array, dimension (N)
*          If .not. WKNOWN, WIN is ignored on input
*          Otherwise, WIN() is taken as the standard by which the
*          eigenvalues are to be compared against.
*
*  WNEW    (global workspace)  REAL array, dimension (N)
*          The eigenvalues as copmuted by this call to PCHEEVD
*          If JOBZ <> 'V' or RANGE <> 'A' these eigenvalues are
*          compared against those in WIN().
*          WNEW has already been padded front and back,
*          use WNEW(1+IPREPAD)
*
*  WORK    (local workspace) COMPLEX array, dimension (LWORK)
*          WORK has already been padded front and back,
*          use WORK(1+IPREPAD)
*
*  LWORK   (local input) INTEGER
*          The actual length of the array WORK after padding.
*
*  RWORK   (local workspace) REAL array, dimension (LRWORK)
*          RWORK has already been padded front and back,
*          use RWORK(1+IPREPAD)
*
*  LRWORK   (local input) INTEGER
*          The actual length of the array RWORK after padding.
*
*  LWORK1  (local input) INTEGER
*          The amount of real workspace to pass to PCHEEVD
*
*  IWORK   (local workspace) INTEGER array, dimension (LIWORK)
*          IWORK has already been padded front and back,
*          use IWORK(1+IPREPAD)
*
*  LIWORK  (local input) INTEGER
*          The length of the array IWORK after padding.
*
*  RESULT  (global output) INTEGER
*          The result of this call to PCHEEVD
*          RESULT = -3   =>  This process did not participate
*          RESULT = 0    =>  All tests passed
*          RESULT = 1    =>  ONe or more tests failed
*
*  TSTNRM  (global output) REAL
*          |AQ- QL| / (ABSTOL+EPS*|A|)*N
*
*  QTQNRM  (global output) REAL
*          |QTQ -I| / N*EPS
*
*     .. Parameters ..
*
      INTEGER            BLOCK_CYCLIC_2D, DLEN_, DTYPE_, CTXT_, M_, N_,
     $                   MB_, NB_, RSRC_, CSRC_, LLD_
      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 )
      REAL               PADVAL, FIVE, NEGONE
      PARAMETER          ( PADVAL = 13.5285E+0, FIVE = 5.0E+0,
     $                   NEGONE = -1.0E+0 )
      COMPLEX            CPADVAL
      PARAMETER          ( CPADVAL = ( 13.989E+0, 1.93E+0 ) )
      INTEGER            IPADVAL
      PARAMETER          ( IPADVAL = 927 )
      COMPLEX            CZERO, CONE, CNEGONE
      PARAMETER          ( CZERO = 0.0E+0, CONE = 1.0E+0,
     $                   CNEGONE = -1.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IAM, INFO, ISIZEHEEVD, ISIZEHEEVX,
     $                   ISIZESUBTST, ISIZETST, MYCOL, MYROW, NP, NPCOL,
     $                   NPROW, NQ, RES, RSIZECHK, RSIZEHEEVD,
     $                   RSIZEHEEVX, RSIZEQTQ, RSIZESUBTST, RSIZETST,
     $                   SIZEHEEVD, SIZEHEEVX, SIZEMQRLEFT,
     $                   SIZEMQRRIGHT, SIZEQRF, SIZESUBTST, SIZETMS,
     $                   SIZETST
      REAL               EPS, EPSNORMA, ERROR, MAXERROR, MINERROR, NORM,
     $                   NORMWIN, SAFMIN, ULP
*     ..
*     .. Local Arrays ..
      INTEGER            ITMP( 2 )
*     ..
*     .. External Functions ..
*
      INTEGER            NUMROC
      REAL               PCLANGE, PCLANHE, PSLAMCH
      EXTERNAL           NUMROC, PCLANGE, PCLANHE, PSLAMCH
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, CLACPY, IGAMN2D, IGAMX2D,
     $                   PCCHEKPAD, PCFILLPAD, PCGEMM, PCHEEVD, PCLASET,
     $                   PCLASIZESEP, PCSEPCHK, PICHEKPAD, PIFILLPAD,
     $                   PSCHEKPAD, PSFILLPAD, SLBOOT, SLTIMER
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, REAL
*     ..
*     .. Executable Statements ..
*       This is just to keep ftnchek happy
      IF( BLOCK_CYCLIC_2D*CSRC_*CTXT_*DLEN_*DTYPE_*LLD_*MB_*M_*NB_*N_*
     $    RSRC_.LT.0 )RETURN
*
      CALL PCLASIZESEP( DESCA, IPREPAD, IPOSTPAD, SIZEMQRLEFT,
     $                  SIZEMQRRIGHT, SIZEQRF, SIZETMS, RSIZEQTQ,
     $                  RSIZECHK, SIZEHEEVX, RSIZEHEEVX, ISIZEHEEVX,
     $                  SIZEHEEVD, RSIZEHEEVD, ISIZEHEEVD, SIZESUBTST,
     $                  RSIZESUBTST, ISIZESUBTST, SIZETST, RSIZETST,
     $                  ISIZETST )
*
      TSTNRM = NEGONE
      QTQNRM = NEGONE
      EPS = PSLAMCH( DESCA( CTXT_ ), 'Eps' )
      SAFMIN = PSLAMCH( DESCA( CTXT_ ), 'Safe min' )
*
      NORMWIN = SAFMIN / EPS
      IF( N.GE.1 )
     $   NORMWIN = MAX( ABS( WIN( 1+IPREPAD ) ),
     $             ABS( WIN( N+IPREPAD ) ), NORMWIN )
*
      DO 10 I = 1, LWORK1, 1
         RWORK( I+IPREPAD ) = 14.3E+0
   10 CONTINUE
      DO 20 I = 1, LIWORK, 1
         IWORK( I ) = 14
   20 CONTINUE
      DO 30 I = 1, LWORK, 1
         WORK( I+IPREPAD ) = ( 15.63E+0, 1.1E+0 )
   30 CONTINUE
*
      DO 40 I = 1, N
         WNEW( I+IPREPAD ) = 3.14159E+0
   40 CONTINUE
*
      CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
*
      IAM = 1
      IF( MYROW.EQ.0 .AND. MYCOL.EQ.0 )
     $   IAM = 0
*
*     If this process is not involved in this test, bail out now
*
      RESULT = -3
      IF( MYROW.GE.NPROW .OR. MYROW.LT.0 )
     $   GO TO 60
      RESULT = 0
*
      NP = NUMROC( N, DESCA( MB_ ), MYROW, 0, NPROW )
      NQ = NUMROC( N, DESCA( NB_ ), MYCOL, 0, NPCOL )
*
      CALL CLACPY( 'A', NP, NQ, COPYA, DESCA( LLD_ ), A( 1+IPREPAD ),
     $             DESCA( LLD_ ) )
*
      CALL PCFILLPAD( DESCA( CTXT_ ), NP, NQ, A, DESCA( LLD_ ), IPREPAD,
     $                IPOSTPAD, CPADVAL )
*
      CALL PCFILLPAD( DESCA( CTXT_ ), NP, NQ, Z, DESCA( LLD_ ), IPREPAD,
     $                IPOSTPAD, CPADVAL+1.0E+0 )
*
      CALL PSFILLPAD( DESCA( CTXT_ ), N, 1, WNEW, N, IPREPAD, IPOSTPAD,
     $                PADVAL+2.0E+0 )
*
      CALL PSFILLPAD( DESCA( CTXT_ ), LWORK1, 1, RWORK, LWORK1, IPREPAD,
     $                IPOSTPAD, PADVAL+4.0E+0 )
*
      CALL PIFILLPAD( DESCA( CTXT_ ), LIWORK, 1, IWORK, LIWORK, IPREPAD,
     $                IPOSTPAD, IPADVAL )
*
      CALL PCFILLPAD( DESCA( CTXT_ ), LWORK, 1, WORK, LWORK, IPREPAD,
     $                IPOSTPAD, CPADVAL+4.1E+0 )
*
      CALL SLBOOT
      CALL SLTIMER( 1 )
      CALL SLTIMER( 6 )
*
      CALL PCHEEVD( 'V', UPLO, N, A( 1+IPREPAD ), IA, JA, DESCA,
     $              WNEW( 1+IPREPAD ), Z( 1+IPREPAD ), IA, JA, DESCA,
     $              WORK( 1+IPREPAD ), SIZEHEEVD, RWORK( 1+IPREPAD ),
     $              LWORK1, IWORK( 1+IPREPAD ), LIWORK, INFO )
      CALL SLTIMER( 6 )
      CALL SLTIMER( 1 )
*
      IF( THRESH.LE.0 ) THEN
         RESULT = 0
      ELSE
         CALL PCCHEKPAD( DESCA( CTXT_ ), 'PCHEEVD-A', NP, NQ, A,
     $                   DESCA( LLD_ ), IPREPAD, IPOSTPAD, CPADVAL )
*
         CALL PCCHEKPAD( DESCA( CTXT_ ), 'PCHEEVD-Z', NP, NQ, Z,
     $                   DESCA( LLD_ ), IPREPAD, IPOSTPAD,
     $                   CPADVAL+1.0E+0 )
*
         CALL PSCHEKPAD( DESCA( CTXT_ ), 'PCHEEVD-WNEW', N, 1, WNEW, N,
     $                   IPREPAD, IPOSTPAD, PADVAL+2.0E+0 )
*
         CALL PSCHEKPAD( DESCA( CTXT_ ), 'PCHEEVD-rWORK', LWORK1, 1,
     $                   RWORK, LWORK1, IPREPAD, IPOSTPAD,
     $                   PADVAL+4.0E+0 )
*
         CALL PCCHEKPAD( DESCA( CTXT_ ), 'PCHEEVD-WORK', LWORK, 1, WORK,
     $                   LWORK, IPREPAD, IPOSTPAD, CPADVAL+4.1E+0 )
*
         CALL PICHEKPAD( DESCA( CTXT_ ), 'PCHEEVD-IWORK', LIWORK, 1,
     $                   IWORK, LIWORK, IPREPAD, IPOSTPAD, IPADVAL )
*
*     Check INFO
*
*     Make sure that all processes return the same value of INFO
*
         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( IAM.EQ.0 )
     $         WRITE( NOUT, FMT = * )
     $         'Different processes return different INFO'
            RESULT = 1
         ELSE IF( INFO.NE.0 ) THEN
            IF( IAM.EQ.0 )
     $         WRITE( NOUT, FMT = 9996 )INFO
            RESULT = 1
         END IF
*
*     Compute eps * norm(A)
*
         IF( N.EQ.0 ) THEN
            EPSNORMA = EPS
         ELSE
            EPSNORMA = PCLANHE( 'I', UPLO, N, COPYA, IA, JA, DESCA,
     $                 RWORK )*EPS
         END IF
*
*     Note that a couple key variables get redefined in PCSEPCHK
*     as described by this table:
*
*     PCSEPTST name         PCSEPCHK name
*     -------------         -------------
*     COPYA                 A
*     Z                     Q
*     A                     C
*
*     Perform the |AQ - QE| test
*
         CALL PSFILLPAD( DESCA( CTXT_ ), RSIZECHK, 1, RWORK, RSIZECHK,
     $                   IPREPAD, IPOSTPAD, 4.3E+0 )
*
         CALL PCSEPCHK( N, N, COPYA, IA, JA, DESCA,
     $                  MAX( ABSTOL+EPSNORMA, SAFMIN ), THRESH,
     $                  Z( 1+IPREPAD ), IA, JA, DESCA, A( 1+IPREPAD ),
     $                  IA, JA, DESCA, WNEW( 1+IPREPAD ),
     $                  RWORK( 1+IPREPAD ), RSIZECHK, TSTNRM, RES )
*
         CALL PSCHEKPAD( DESCA( CTXT_ ), 'PCSDPCHK-rWORK', RSIZECHK, 1,
     $                   RWORK, RSIZECHK, IPREPAD, IPOSTPAD, 4.3E+0 )
*
         IF( RES.NE.0 ) THEN
            RESULT = 1
            WRITE( NOUT, FMT = 9995 )
         END IF
*
*     Perform the |QTQ - I| test
*
         CALL PSFILLPAD( DESCA( CTXT_ ), RSIZEQTQ, 1, RWORK, RSIZEQTQ,
     $                   IPREPAD, IPOSTPAD, 4.3E+0 )
*
*
         RES = 0
         ULP = PSLAMCH( DESCA( CTXT_ ), 'P' )
         CALL PCLASET( 'A', N, N, CZERO, CONE, A( 1+IPREPAD ), IA, JA,
     $                 DESCA )
         CALL PCGEMM( 'Conjugate transpose', 'N', N, N, N, CNEGONE,
     $                Z( 1+IPREPAD ), IA, JA, DESCA, Z( 1+IPREPAD ), IA,
     $                JA, DESCA, CONE, A( 1+IPREPAD ), IA, JA, DESCA )
         NORM = PCLANGE( '1', N, N, A( 1+IPREPAD ), IA, JA, DESCA,
     $          WORK( 1+IPREPAD ) )
         QTQNRM = NORM / ( REAL( MAX( N, 1 ) )*ULP )
         IF( QTQNRM.GT.THRESH ) THEN
            RES = 1
         END IF
         CALL PSCHEKPAD( DESCA( CTXT_ ), 'PCSEPQTQ-rWORK', RSIZEQTQ, 1,
     $                   RWORK, RSIZEQTQ, IPREPAD, IPOSTPAD, 4.3E+0 )
*
         IF( RES.NE.0 ) THEN
            RESULT = 1
            WRITE( NOUT, FMT = 9994 )
         END IF
*
         IF( INFO.NE.0 ) THEN
            IF( IAM.EQ.0 )
     $         WRITE( NOUT, FMT = 9998 )INFO
            RESULT = 1
         END IF
*
         IF( INFO.NE.0 ) THEN
            IF( IAM.EQ.0 )
     $         WRITE( NOUT, FMT = 9998 )INFO
            RESULT = 1
         END IF
      END IF
*
*     Check to make sure that we have the right eigenvalues
*
      IF( WKNOWN .AND. N.GT.0 ) THEN
*
*     Find the largest difference between the computed
*     and expected eigenvalues
*
         MINERROR = NORMWIN
         MAXERROR = 0.0
*
         DO 50 I = 1, N
            ERROR = ABS( WIN( I+IPREPAD )-WNEW( I+IPREPAD ) )
            MAXERROR = MAX( MAXERROR, ERROR )
   50    CONTINUE
         MINERROR = MIN( MAXERROR, MINERROR )
*
         IF( MINERROR.GT.NORMWIN*FIVE*THRESH*EPS ) THEN
            IF( IAM.EQ.0 )
     $         WRITE( NOUT, FMT = 9997 )MINERROR, NORMWIN
            RESULT = 1
         END IF
      END IF
*
*
*     All processes should report the same result
*
      CALL IGAMX2D( DESCA( CTXT_ ), 'a', ' ', 1, 1, RESULT, 1, 1, 1, -1,
     $              -1, 0 )
*
   60 CONTINUE
*
      RETURN
*
 9999 FORMAT( 'PCHEEVD returned INFO=', I7 )
 9998 FORMAT( 'PCSEPQTQ returned INFO=', I7 )
 9997 FORMAT( 'PCSDPSUBTST minerror =', D11.2, ' normwin=', D11.2 )
 9996 FORMAT( 'PCHEEVD returned INFO=', I7,
     $      ' despite adequate workspace' )
 9995 FORMAT( 'PCHEEVD failed the |AQ -QE| test' )
 9994 FORMAT( 'PCHEEVD failed the |QTQ -I| test' )
*
*     End of PCSDPSUBTST
*
      END


      SUBROUTINE SB04MD( N, M, A, LDA, B, LDB, C, LDC, Z, LDZ, IWORK,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To solve for X the continuous-time Sylvester equation
C
C        AX + XB = C
C
C     where A, B, C and X are general N-by-N, M-by-M, N-by-M and
C     N-by-M matrices respectively.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The order of the matrix B.  M >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the coefficient matrix A of the equation.
C             On exit, the leading N-by-N upper Hessenberg part of this
C             array contains the matrix H, and the remainder of the
C             leading N-by-N part, together with the elements 2,3,...,N
C             of array DWORK, contain the orthogonal transformation
C             matrix U (stored in factored form).
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading M-by-M part of this array must
C             contain the coefficient matrix B of the equation.
C             On exit, the leading M-by-M part of this array contains
C             the quasi-triangular Schur factor S of the matrix B'.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,M).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,M)
C             On entry, the leading N-by-M part of this array must
C             contain the coefficient matrix C of the equation.
C             On exit, the leading N-by-M part of this array contains
C             the solution matrix X of the problem.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,N).
C
C     Z       (output) DOUBLE PRECISION array, dimension (LDZ,M)
C             The leading M-by-M part of this array contains the
C             orthogonal matrix Z used to transform B' to real upper
C             Schur form.
C
C     LDZ     INTEGER
C             The leading dimension of array Z.  LDZ >= MAX(1,M).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (4*N)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK, and DWORK(2), DWORK(3),..., DWORK(N) contain
C             the scalar factors of the elementary reflectors used to
C             reduce A to upper Hessenberg form, as returned by LAPACK
C             Library routine DGEHRD.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK = MAX(1, 2*N*N + 8*N, 5*M, N + M).
C             For optimum performance LDWORK should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message related to LDWORK is issued by
C             XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  if INFO = i, 1 <= i <= M, the QR algorithm failed to
C                   compute all the eigenvalues (see LAPACK Library
C                   routine DGEES);
C             > M:  if a singular matrix was encountered whilst solving
C                   for the (INFO-M)-th column of matrix X.
C
C     METHOD
C
C     The matrix A is transformed to upper Hessenberg form H = U'AU by
C     the orthogonal transformation matrix U; matrix B' is transformed
C     to real upper Schur form S = Z'B'Z using the orthogonal
C     transformation matrix Z. The matrix C is also multiplied by the
C     transformations, F = U'CZ, and the solution matrix Y of the
C     transformed system
C
C        HY + YS' = F
C
C     is computed by back substitution. Finally, the matrix Y is then
C     multiplied by the orthogonal transformation matrices, X = UYZ', in
C     order to obtain the solution matrix X to the original problem.
C
C     REFERENCES
C
C     [1] Golub, G.H., Nash, S. and Van Loan, C.F.
C         A Hessenberg-Schur method for the problem AX + XB = C.
C         IEEE Trans. Auto. Contr., AC-24, pp. 909-913, 1979.
C
C     NUMERICAL ASPECTS
C                                         3       3      2         2
C     The algorithm requires about (5/3) N  + 10 M  + 5 N M + 2.5 M N
C     operations and is backward stable.
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997.
C     Supersedes Release 2.0 routine SB04AD by G. Golub, S. Nash, and
C     C. Van Loan, Stanford University, California, United States of
C     America, January 1982.
C
C     REVISIONS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, June 2000, Aug. 2000.
C     V. Sima, Research Institute for Informatics, Bucharest, July 2011.
C
C     KEYWORDS
C
C     Hessenberg form, orthogonal transformation, real Schur form,
C     Sylvester equation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDB, LDC, LDWORK, LDZ, M, N
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), Z(LDZ,*)
C     .. Local Scalars ..
      LOGICAL           LQUERY
      INTEGER           I, IEIG, IFAIL, IHI, ILO, IND, ITAU, JWORK,
     $                  MINDW, SDIM, WRKOPT
C     .. Local Arrays ..
      LOGICAL           BWORK(1)
C     .. External Functions ..
      LOGICAL           SELECT
      EXTERNAL          SELECT
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEES, DGEHRD, DGEMM, DGEMV, DLACPY,
     $                  DORMHR, DSWAP, SB04MU, SB04MY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX
C     .. Executable Statements ..
C
      INFO   = 0
      LQUERY = LDWORK.EQ.-1
C
C     Test the input scalar arguments.
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
         INFO = -6
      ELSE IF( LDC.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDZ.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE
         ILO = 1
         IHI = N
         MINDW = MAX( 1, 2*N*N + 8*N, 5*M, N + M )
         IF( LQUERY ) THEN
            CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, B, LDB,
     $                  SDIM, DWORK, DWORK, Z, LDZ, DWORK, -1, BWORK,
     $                  IFAIL )
            WRKOPT = MAX( MINDW, 2*M + INT( DWORK(1) ) )
            CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK, DWORK, -1, IFAIL )
            WRKOPT = MAX( WRKOPT, N + INT( DWORK(1) ) )
            CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, A, LDA,
     $                   DWORK, C, LDC, DWORK, -1, IFAIL )
            WRKOPT = MAX( WRKOPT, N + INT( DWORK(1) ) )
            CALL DORMHR( 'Left', 'No transpose', N, M, ILO, IHI, A, LDA,
     $                   DWORK, C, LDC, DWORK, -1, IFAIL )
            WRKOPT = MAX( WRKOPT, N + INT( DWORK(1) ) )
         ELSE IF( LDWORK.LT.MINDW ) THEN
            INFO = -13
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB04MD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 .OR. M.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      WRKOPT = 1
C
C     Step 1 : Reduce A to upper Hessenberg and B' to quasi-upper
C              triangular. That is, H = U' * A * U (store U in factored
C              form) and S = Z' * B' * Z (save Z).
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.
C     NB refers to the optimal block size for the immediately
C     following subroutine, as returned by ILAENV.)
C
      DO 20 I = 2, M
         CALL DSWAP( I-1, B(1,I), 1, B(I,1), LDB )
   20 CONTINUE
C
C     Workspace:  need   5*M;
C                 prefer larger.
C
      IEIG  = M + 1
      JWORK = IEIG + M
      CALL DGEES( 'Vectors', 'Not ordered', SELECT, M, B, LDB,
     $            SDIM, DWORK, DWORK(IEIG), Z, LDZ, DWORK(JWORK),
     $            LDWORK-JWORK+1, BWORK, INFO )
      IF ( INFO.NE.0 )
     $   RETURN
      WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C     Workspace:  need   2*N;
C                 prefer N + N*NB.
C
      ITAU  = 2
      JWORK = ITAU + N - 1
      CALL DGEHRD( N, ILO, IHI, A, LDA, DWORK(ITAU), DWORK(JWORK),
     $             LDWORK-JWORK+1, IFAIL )
      WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C     Step 2 : Form  F = ( U' * C ) * Z.  Use BLAS 3, if enough space.
C
C     Workspace:  need   N + M;
C                 prefer N + M*NB.
C
      CALL DORMHR( 'Left', 'Transpose', N, M, ILO, IHI, A, LDA,
     $             DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1,
     $             IFAIL )
      WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
      IF ( LDWORK.GE.JWORK - 1 + N*M ) THEN
         CALL DGEMM( 'No transpose', 'No transpose', N, M, M, ONE, C,
     $               LDC, Z, LDZ, ZERO, DWORK(JWORK), N )
         CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC )
         WRKOPT = MAX( WRKOPT, JWORK - 1 + N*M )
      ELSE
C
         DO 40 I = 1, N
            CALL DGEMV( 'Transpose', M, M, ONE, Z, LDZ, C(I,1), LDC,
     $                  ZERO, DWORK(JWORK), 1 )
            CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC )
   40    CONTINUE
C
      END IF
C
      IND = M
   60 CONTINUE
      IF ( IND.GT.1 ) THEN
C
C        Step 3 : Solve  H * Y + Y * S' = F  for  Y.
C
         IF ( B(IND,IND-1).EQ.ZERO ) THEN
C
C           Solve a special linear algebraic system of order N.
C           Workspace:  N*(N+1)/2 + 3*N.
C
            CALL SB04MY( M, N, IND, A, LDA, B, LDB, C, LDC,
     $                   DWORK(JWORK), IWORK, INFO )
C
            IF ( INFO.NE.0 ) THEN
               INFO = INFO + M
               RETURN
            END IF
            WRKOPT = MAX( WRKOPT, JWORK + N*( N + 1 )/2 + 2*N - 1 )
            IND = IND - 1
         ELSE
C
C           Solve a special linear algebraic system of order 2*N.
C           Workspace:  2*N*N + 8*N;
C
            CALL SB04MU( M, N, IND, A, LDA, B, LDB, C, LDC,
     $                   DWORK(JWORK), IWORK, INFO )
C
            IF ( INFO.NE.0 ) THEN
               INFO = INFO + M
               RETURN
            END IF
            WRKOPT = MAX( WRKOPT, JWORK + 2*N*N + 7*N - 1 )
            IND = IND - 2
         END IF
         GO TO 60
      ELSE IF ( IND.EQ.1 ) THEN
C
C        Solve a special linear algebraic system of order N.
C        Workspace:  N*(N+1)/2 + 3*N;
C
         CALL SB04MY( M, N, IND, A, LDA, B, LDB, C, LDC,
     $                DWORK(JWORK), IWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            INFO = INFO + M
            RETURN
         END IF
         WRKOPT = MAX( WRKOPT, JWORK + N*( N + 1 )/2 + 2*N - 1 )
      END IF
C
C     Step 4 : Form  C = ( U * Y ) * Z'.  Use BLAS 3, if enough space.
C
C     Workspace:  need   N + M;
C                 prefer N + M*NB.
C
      CALL DORMHR( 'Left', 'No transpose', N, M, ILO, IHI, A, LDA,
     $             DWORK(ITAU), C, LDC, DWORK(JWORK), LDWORK-JWORK+1,
     $             IFAIL )
      WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
      IF ( LDWORK.GE.JWORK - 1 + N*M ) THEN
         CALL DGEMM( 'No transpose', 'Transpose', N, M, M, ONE, C, LDC,
     $               Z, LDZ, ZERO, DWORK(JWORK), N )
         CALL DLACPY( 'Full', N, M, DWORK(JWORK), N, C, LDC )
      ELSE
C
         DO 80 I = 1, N
            CALL DGEMV( 'No transpose', M, M, ONE, Z, LDZ, C(I,1), LDC,
     $                  ZERO, DWORK(JWORK), 1 )
            CALL DCOPY( M, DWORK(JWORK), 1, C(I,1), LDC )
   80    CONTINUE
      END IF
C
      DWORK(1) = WRKOPT
      RETURN
C *** Last line of SB04MD ***
      END


c
c
c     =====================================================
      subroutine rpt2(ixy,maxm,meqn,mwaves,mbc,mx,
     &                  ql,qr,aux1,aux2,aux3,
     &                  imp,asdq,bmasdq,bpasdq)
c     =====================================================
      implicit double precision (a-h,o-z)
c
c     # Riemann solver in the transverse direction for the acoustics equations.
c
c     # Split asdq into down-going flux bmasdq and up-going flux bpasdq.
c
      dimension     ql(1-mbc:maxm+mbc, meqn)
      dimension     qr(1-mbc:maxm+mbc, meqn)
      dimension   asdq(1-mbc:maxm+mbc, meqn)
      dimension bmasdq(1-mbc:maxm+mbc, meqn)
      dimension bpasdq(1-mbc:maxm+mbc, meqn)
c
c     # density, bulk modulus, and sound speed, and impedence of medium:
c     # (should be set in setprob.f)
      common /cparam/ rho,bulk,cc,zz

c
      if (ixy.eq.1) then
          mu = 2
          mv = 3
        else
          mu = 3
          mv = 2
        endif
c
      do 20 i = 2-mbc, mx+mbc
         a1 = (-asdq(i,1) + zz*asdq(i,mv)) / (2.d0*zz)
         a2 = (asdq(i,1) + zz*asdq(i,mv)) / (2.d0*zz)
c
c        # The down-going flux difference bmasdq is the product  -c * wave
c
         bmasdq(i,1) = cc * a1*zz
         bmasdq(i,mu) = 0.d0
         bmasdq(i,mv) = -cc * a1
c
c        # The up-going flux difference bpasdq is the product  c * wave
c
         bpasdq(i,1) = cc * a2*zz
         bpasdq(i,mu) = 0.d0
         bpasdq(i,mv) = cc * a2
c
   20    continue
c
      return
      end


C
C************************* KERSH **********************************
C
      subroutine kersh(iout,nequ,nterm,ia,ja,sysmat,prec)
c
c  incomplete Choleski decompostion
c
      implicit none
c
      integer  iout,nequ,nterm
cxcx  integer  ia(nequ+1),JA(nterm)
      integer  ia(*),JA(*)

      integer  i,j,k,kk,k1,i1,j1,k2

cxcx  real*8   prec(nterm),sysmat(nterm)
      real*8   prec(*),sysmat(*)
      real*8   a,zero

      parameter (zero=0.0d0)

      do k=1,nterm
         prec(k) = zero
      end do

      do kk=1,nequ-1

         k = ia(kk)
         a = sysmat(k) - prec(k)
         if(a.le.zero) then
            write(iout,100) kk,a
            write(iout,101) prec(ia(kk-1))
            a = (prec(ia(kk-1)))**2
         end if
         prec(K) = sqrt(a)

         i = ia(kk) + 1
         j = ia(kk+1) - 1

         do k1 = i,j
            prec(k1) = (sysmat(k1)-prec(k1))/prec(k)
         end do

         do k2 = i,j-1

            j1 = ia(ja(k2))
            prec(j1) = prec(j1) + prec(k2)**2
            i1 = k2 + 1
            j1 = j1 + 1
            do while(j1.lt.ia(ja(k2)+1).and.i1.le.j)
               if(ja(j1).eq.ja(i1)) then
                  prec(j1) = prec(j1) + prec(k2)*prec(i1)
                  i1 = i1 + 1
                  j1 = j1 + 1
               else if (ja(j1).lt.ja(i1))then
                  j1 = j1 + 1
               else if (ja(j1).gt.ja(i1))then
                   i1 = i1 + 1
               end if
            end do

         end do

         if(j.ge.i)
     1        prec(ia(ja(j))) = prec(ia(ja(j))) + prec(k2)**2

      end do

      k = ia(nequ)
      a = sysmat(k)-prec(k)
      if(a.le.zero) then
         write(iout,100) nequ ,a
         write(iout,101) prec(ia(nequ-1))
         a = (prec(ia(nequ-1)))**2
      end if
      prec(k) = sqrt(a)

      return
100   format('*** Subroutine Kersh: diagonal',
     1       ' element <= zero at position: ',I5,2X,E16.5)
101   format('***** using previous diagonal value: ',E16.8)
      end


#include "scalar.fpp"

!=====================================================================!
! Module that implements solving a nonlinear problem using different
! methods such as Newton's method.
!=====================================================================!

module nonlinear_algebra

  ! import dependencies
  use iso_fortran_env           , only : dp => REAL64
  use linear_algebra            , only : tdma, linsolve => solve
  use dynamic_physics_interface , only : dynamics
  use utils                     , only : norm

  ! disable implicit datatypes
  implicit none

  ! Define constants used
  real(dp) :: abs_res_tol          = 1.0d-14
  real(dp) :: rel_res_tol          = 1.0d-10

  integer  :: max_newton_iters     = 15
  integer  :: print_level          = 0

  public :: solve

  !-------------------------------------------------------------------!
  ! Interface for nonlinear solution problems
  !-------------------------------------------------------------------!

  interface solve
     module procedure newton_solve_condensed
  end interface solve

contains

  !==================================================================!
  ! Newton solve for condensed form of equations
  !==================================================================!

  subroutine newton_solve_condensed(system, coeff, t, U, X, rhs)

    class(dynamics) , intent(inout) :: system
    type(scalar)    , intent(in)    :: coeff(:)
    type(scalar)    , intent(in)    :: t
    type(scalar)    , intent(inout) :: U(:,:)
    type(scalar)   , intent(in)     :: X(:,:)
    type(scalar)   , intent(in), optional :: rhs(:)

    ! Norms for tracking progress
    real(dp)                                  :: abs_res_norm = 0
    real(dp)                                  :: rel_res_norm = 0
    real(dp)                                  :: init_norm    = 0

    ! Other Local variables
    type(scalar), allocatable, dimension(:)   :: res, dq
    type(scalar), allocatable, dimension(:,:) :: jac

    integer                                   :: n, nvars, jj
    logical                                   :: conv = .false.

    ! find the size of the linear system based on the calling object
    nvars = system % get_num_state_vars()

    if (.not. allocated(res)) allocate(res(nvars))
    if (.not. allocated(dq)) allocate(dq(nvars))
    if (system % sparse .eqv. .true.) then
       if (.not.allocated(jac)) allocate(jac(nvars,3)) ! system % get_bandwidth() #TODO
    else
       if (.not.allocated(jac)) allocate(jac(nvars,nvars))
    end if

    if ( print_level .ge. 1 ) then
       write(*,'(A11, 2A12)') "Newton-Iter", "|R|", "|R|/|R1|"
    end if

    newton: do n = 1, max_newton_iters

       res = 0.0d0
       call system % add_residual(res, U, X)

       ! Handle arbitrary rhs external to system
       if (present(rhs)) then
          res = res + rhs
       end if

       jac = 0.0d0
       if ( (system % approximate_jacobian .eqv. .true.) .and. (system % sparse .eqv. .false.) ) then
          call approximate_jacobian(system, jac, coeff, U, X)
       else
          call system % add_jacobian(jac, coeff, U, X)
       end if

       ! Find norm of the residual
       abs_res_norm = norm(res)
       if ( n .eq. 1) init_norm = abs_res_norm
       rel_res_norm = abs_res_norm/(init_norm + tiny(1.0d0))

       if ( print_level .eq. 2) then
          write(*, "(I10,2ES12.2)") n, abs_res_norm, rel_res_norm
       end if

       ! Check stopping
       if ((abs_res_norm .le. abs_res_tol) .or. (rel_res_norm .le. rel_res_tol)) then
          conv = .true.
          exit newton
       else if ((abs_res_norm .ne. abs_res_norm) .or. (rel_res_norm .ne. rel_res_norm) ) then
          conv = .false.
          exit newton
       end if

       ! Solve the linear system
       if (system % sparse .eqv. .true.) then
          ! works currently only for tridiagonal systems
          res = -res
          call tdma(jac, res, dq)
       else
          dq = linsolve(jac, -res)
       end if

       ! Apply BCs on dq
       ! call system % apply_bc(dq)?
       ! print *, 'update', dq(1), dq(nvars)
       ! dq(1) = 0.0d0
       ! dq(nvars) = 0.0d0

       forall(jj=1:system % get_differential_order() + 1)
          U(jj,:) = U(jj,:) + coeff(jj)*dq
       end forall

    end do newton

    if (print_level .eq. 1) then
       write(*, "(I10,2ES12.2)") n, abs_res_norm, rel_res_norm
    end if

    ! Print warning message if not converged
    if (.not. conv) then
       write(*,'(A5, 2A12)') "ITER", "|R|", "|R|/|R1|"
       write(*, "(I5,2ES12.2)") n, abs_res_norm, rel_res_norm
       stop "Newton Solve Failed"
    end if

    if (allocated(res))    deallocate(res)
    if (allocated(dq))     deallocate(dq)
    if (allocated(jac))    deallocate(jac)

  end subroutine newton_solve_condensed

  !===================================================================!
  ! Solve the nonlinear system at each step by driving the
  ! residual to zero
  !
  ! Input:
  ! The guessed (initial) state variable values q, qdot, qddot are
  ! supplied
  !
  ! Output:
  ! q, qdot, qddot updated iteratively until the corresponding
  ! residual R = 0
  !
  ! alpha: multiplier for derivative of Residual wrt to q
  ! beta : multiplier for derivative of Residual wrt to qdot
  ! gamma: multiplier for derivative of Residual wrt to qddot
  !===================================================================!
!!$
!!$  subroutine solve_second_order( system, alpha, beta, gamma, t, q, qdot, qddot )
!!$    use physics_class, only: phyics
!!$    class(dynamics) :: system
!!$
!!$    ! Arguments
!!$    type(scalar), intent(in)                  :: alpha, beta, gamma
!!$    real(dp), intent(in)                      :: t
!!$    type(scalar), intent(inout), dimension(:) :: q, qdot, qddot
!!$
!!$    ! Norms for tracking progress
!!$    real(dp)                                  :: abs_res_norm = 0.0d0
!!$    real(dp)                                  :: rel_res_norm = 0.0d0
!!$    real(dp)                                  :: init_norm    = 0.0d0
!!$
!!$    ! Other Local variables
!!$    type(scalar), allocatable, dimension(:)   :: res, dq
!!$    type(scalar), allocatable, dimension(:,:) :: jac, fd_jac
!!$
!!$    integer                                   :: n, nvars
!!$    logical                                   :: conv = .false.
!!$
!!$    type(scalar)                              :: jac_err
!!$
!!$    ! find the size of the linear system based on the calling object
!!$    nvars = size(q)
!!$
!!$    if ( .not. allocated(res)    ) allocate( res(nvars)         )
!!$    if ( .not. allocated(dq)     ) allocate( dq(nvars)          )
!!$    if ( .not. allocated(jac)    ) allocate( jac(nvars,nvars)    )
!!$    if ( .not. allocated(fd_jac) ) allocate( fd_jac(nvars,nvars) )
!!$
!!$    if ( print_level .ge. 1) then
!!$       write(*,'(A10, 2A12)') "NewtonIter", "|R|", "|R|/|R1|"
!!$    end if
!!$
!!$    newton: do n = 1, max_newton_iters
!!$
!!$       call system % assembleResidual(res, t, q, qdot, qddot)
!!$
!!$       ! Get the jacobian matrix
!!$       if ( approximate_jac) then
!!$
!!$          ! Compute an approximate Jacobian using finite differences
!!$          call approximateJacobian(system, jac, alpha, beta, gamma, t, q, qdot, qddot)
!!$
!!$       else
!!$
!!$          ! Use the user supplied Jacobian implementation
!!$          call system % assembleJacobian(jac, alpha, beta, gamma, t, q, qdot, qddot)
!!$
!!$          ! Check the Jacobian implementation once at the beginning of integration
!!$          if ( jacobian_check .and. n .eq. 1 ) then
!!$
!!$             ! Compute an approximate Jacobian using finite differences
!!$             call approximateJacobian(system, fd_jac, alpha, beta, gamma, t, q, qdot, qddot)
!!$
!!$             ! Compare the exact and approximate Jacobians and
!!$             ! complain about the error in Jacobian if there is any
!!$             jac_err = maxval(abs(fd_jac - jac))
!!$             if ( abs(jac_err) .gt. 1.0d-3 ) then
!!$                print *, "q     =", q
!!$                print *, "qdot  =", qdot
!!$                print *, "qddot =", qddot
!!$                print *, "a,b,c =", alpha, beta, gamma
!!$                print *, "J     =", jac
!!$                print *, "Jhat  =", fd_jac
!!$                print *, "WARNING: Possible error in jacobian", jac_err
!!$             end if
!!$
!!$             ! Set that the jacobian is checked
!!$             jacobian_check = .false.
!!$
!!$          end if
!!$
!!$       end if
!!$
!!$       ! Find norm of the residual
!!$       abs_res_norm = norm(res)
!!$       if ( n .eq. 1) init_norm = abs_res_norm
!!$       rel_res_norm = abs_res_norm/init_norm
!!$
!!$       if ( print_level .eq. 2) then
!!$          write(*, "(I10,2ES12.2)") n, abs_res_norm, rel_res_norm
!!$       end if
!!$
!!$       ! Check stopping
!!$       if ((abs_res_norm .le. abs_res_tol) .or. (rel_res_norm .le. rel_res_tol)) then
!!$          conv = .true.
!!$          exit newton
!!$       else if ((abs_res_norm .ne. abs_res_norm) .or. (rel_res_norm .ne. rel_res_norm) ) then
!!$          conv = .false.
!!$          exit newton
!!$       end if
!!$
!!$       ! Call LAPACK to solve the linear system
!!$       dq = solve(jac, -res)
!!$
!!$       ! Update the solution
!!$       qddot = qddot + gamma * dq
!!$       qdot  = qdot  + beta  * dq
!!$       q     = q     + alpha * dq
!!$
!!$    end do newton
!!$
!!$    if (print_level .eq. 1) then
!!$       write(*, "(I10,2ES12.2)") n, abs_res_norm, rel_res_norm
!!$    end if
!!$
!!$    ! Print warning message if not converged
!!$    if (.not. conv) then
!!$       write(*,'(A5, 2A12)') "ITER", "|R|", "|R|/|R1|"
!!$       write(*, "(I5,2ES12.2)") n, abs_res_norm, rel_res_norm
!!$       stop "Newton Solve Failed"
!!$    end if
!!$
!!$    if (allocated(res)) deallocate(res)
!!$    if (allocated(dq)) deallocate(dq)
!!$    if (allocated(jac)) deallocate(jac)
!!$    if (allocated(fd_jac)) deallocate(fd_jac)
!!$
!!$  end subroutine solve_second_order

!!$  subroutine newton_solve_condensed(system, coeff, U)
!!$
!!$    use dynamics_class, only  : dynamics
!!$
!!$    class(dynamics)                            :: system
!!$
!!$    ! Arguments
!!$    type(scalar), intent(in)                  :: coeff(:)
!!$    type(scalar), intent(inout)               :: U(:,:)
!!$
!!$    ! Other Local variables
!!$    type(scalar), allocatable, dimension(:)   :: res, dq
!!$    type(scalar), allocatable, dimension(:,:) :: jac, fd_jac
!!$
!!$    integer                                   :: n, k, nvars
!!$    logical                                   :: conv = .false.
!!$
!!$
!!$  !===================================================================!
!!$  ! Routine that approximates the Jacobian based on finite differences
!!$  ! [d{R}/d{q}] = alpha*[dR/dq] + beta*[dR/dqdot] + gamma*[dR/dqddot]
!!$  !===================================================================!
!!$
!!$  subroutine approximateJacobian( system, jac, alpha, beta, gamma, t, q, qdot, qddot )
!!$
!!$    class(dynamics)                            :: system
!!$
!!$    ! Matrices
!!$    type(scalar) , intent(inout), dimension(:,:) :: jac
!!$
!!$    ! Arrays
!!$    real(dp)     , intent(in)                    :: t
!!$    type(scalar) , intent(in), dimension(:)      :: q, qdot, qddot     ! states
!!$
!!$    type(scalar) , allocatable, dimension(:)     :: pstate             ! perturbed states
!!$    type(scalar) , allocatable, dimension(:)     :: R, Rtmp            ! original residual and perturbed residual
!!$
!!$    ! Scalars
!!$    type(scalar)                                 :: dh = 1.0d-6        ! finite-diff step size
!!$    type(scalar) , intent(in)                    :: alpha, beta, gamma ! linearization coefficients
!!$    integer                                      :: m                  ! loop variables
!!$    integer :: nvars
!!$
!!$    !  Zero the supplied jacobian matrix for safety (as we are
!!$    !  computing everything newly here)
!!$    jac = 0.0d0
!!$
!!$    nvars = size(q)
!!$
!!$    ! Allocate required arrays
!!$    allocate(pstate(nvars)); pstate = 0.0d0;
!!$    allocate(R(nvars));      R = 0.0d0;
!!$    allocate(Rtmp(nvars));   Rtmp = 0.0d0;
!!$
!!$    ! Make a residual call with original variables
!!$    call system % assembleResidual(R, t, q, qdot, qddot)
!!$
!!$    !-----------------------------------------------------------!
!!$    ! Derivative of R WRT Q: dR/dQ
!!$    !-----------------------------------------------------------!
!!$
!!$    pstate = q
!!$
!!$    loop_vars: do m = 1, nvars
!!$
!!$       ! Perturb the k-th variable
!!$       pstate(m) = pstate(m) + dh
!!$
!!$       ! Make a residual call with the perturbed variable
!!$       call system % assembleResidual(Rtmp, t, pstate, qdot, qddot)
!!$
!!$       ! Unperturb (restore) the k-th variable
!!$       pstate(m) =  q(m)
!!$
!!$       ! Approximate the jacobian with respect to the k-th variable
!!$       jac(:,m) = jac(:,m) + alpha*(Rtmp-R)/dh
!!$
!!$    end do loop_vars
!!$
!!$    !-----------------------------------------------------------!
!!$    ! Derivative of R WRT QDOT: dR/dQDOT
!!$    !-----------------------------------------------------------!
!!$
!!$    pstate = qdot
!!$
!!$    do m = 1, nvars
!!$
!!$       ! Perturb the k-th variable
!!$       pstate(m) = pstate(m) + dh
!!$
!!$       ! Make a residual call with the perturbed variable
!!$       call system % assembleResidual(Rtmp, t, q, pstate, qddot)
!!$
!!$       ! Unperturb (restore) the k-th variable
!!$       pstate(m) =  qdot(m)
!!$
!!$       ! Approximate the jacobian with respect to the k-th variable
!!$       Jac(:,m) = Jac(:,m) + beta*(Rtmp-R)/dh
!!$
!!$    end do
!!$
!!$    ! Second order equations have an extra block to add
!!$    if (second_order) then
!!$
!!$       !-----------------------------------------------------------!
!!$       ! Derivative of R WRT QDDOT: dR/dQDDOT
!!$       !-----------------------------------------------------------!
!!$
!!$       pstate = qddot
!!$
!!$       do m = 1, nvars
!!$
!!$          ! Perturb the k-th variable
!!$          pstate(m) = pstate(m) + dh
!!$
!!$          ! Make a residual call with the perturbed variable
!!$          call system % assembleResidual(Rtmp, t, q, qdot, pstate)
!!$
!!$          ! Unperturb (restore) the k-th variable
!!$          pstate(m) =  qddot(m)
!!$
!!$          ! Approximate the jacobian with respect to the k-th variable
!!$          Jac(:,m) = Jac(:,m) + gamma*(Rtmp-R)/dh
!!$
!!$       end do
!!$
!!$    end if ! first or second order
!!$
!!$    deallocate(pstate)
!!$    deallocate(R,Rtmp)
!!$
!!$  end subroutine approximateJacobian
!!$
!!$

  !===================================================================!
  ! Routine that approximates the Jacobian based on finite differences
  ! [d{R}/d{q}] = alpha*[dR/dq] + beta*[dR/dqdot] + gamma*[dR/dqddot]
  !===================================================================!

  subroutine approximate_jacobian( system, jac, coeff, U, X )

    class(dynamics)                              :: system
    type(scalar) , intent(inout) :: jac(:,:)
    type(scalar) , intent(inout)      :: U(:,:)                  ! states
    type(scalar)   , intent(in)    :: X(:,:)
!@    type(scalar) , allocatable, dimension(:)     :: pstate           ! perturbed ates
    type(scalar) , allocatable, dimension(:)     :: R, Rtmp            ! original residual and perturbed residual

    ! Scalars
    type(scalar)                                 :: dh = 1.0d-6       ! finite-diff step size
    type(scalar) , intent(in)                    :: coeff(:)          ! linearization coefficients
    integer                                      :: m                 ! loop variables
    integer :: nvars

    if (system % get_differential_order() .gt. 2) then
       print *, 'error: using approximate jacobian for system order > 2'
       stop
    end if

    !  Zero the supplied jacobian matrix for safety (as we are
    !  computing everything newly here)
    jac = 0.0d0

    nvars = system % get_num_state_vars()

    ! Allocate required arrays
    !   allocate(pstate(nvars)); pstate = 0.0d0;
    allocate(R(nvars));      R = 0.0d0;
    allocate(Rtmp(nvars));   Rtmp = 0.0d0;

    ! Make a residual call with original variables
    R = 0.0d0
    call system % add_residual(R,  U, X)

    !-----------------------------------------------------------!
    ! Derivative of R WRT Q: dR/dQ
    !-----------------------------------------------------------!

    associate (pstate => U(1,:), alpha=> coeff(1))

      loop_vars: do m = 1, nvars

         ! Perturb the k-th variable
         pstate(m) = pstate(m) + dh

         ! Make a residual call with the perturbed variable
         rtmp = 0
         call system % add_residual(Rtmp, U, X)

         ! Unperturb (restore) the k-th variable
         pstate(m) =  pstate(m) - dh

         ! Approximate the jacobian with respect to the k-th variable
         jac(:,m) = jac(:,m) + alpha*(Rtmp-R)/dh

      end do loop_vars

    end associate

    !-----------------------------------------------------------!
    ! Derivative of R WRT QDOT: dR/dQDOT
    !-----------------------------------------------------------!

    associate (pstate => U(2,:), beta => coeff(2))

      do m = 1, nvars

         ! Perturb the k-th variable
         pstate(m) = pstate(m) + dh

         ! Make a residual call with the perturbed variable
         rtmp = 0
         call system % add_residual(Rtmp, U, X)

         ! Unperturb (restore) the k-th variable
         pstate(m) = pstate(m) - dh

         ! Approximate the jacobian with respect to the k-th variable
         Jac(:,m) = Jac(:,m) + beta*(Rtmp-R)/dh

      end do

    end associate

    ! Second order equations have an extra block to add
    if (system % get_differential_order() == 2) then

       !-----------------------------------------------------------!
       ! Derivative of R WRT QDDOT: dR/dQDDOT
       !-----------------------------------------------------------!
       associate (pstate => U(3,:), gamma => coeff(3))

       do m = 1, nvars

          ! Perturb the k-th variable
          pstate(m) = pstate(m) + dh

          ! Make a residual call with the perturbed variable
          rtmp = 0
          call system % add_residual(Rtmp, U, X)

          ! Unperturb (restore) the k-th variable
          pstate(m) = pstate(m) - dh

          ! Approximate the jacobian with respect to the k-th variable
          Jac(:,m) = Jac(:,m) + gamma*(Rtmp-R)/dh

       end do

     end associate

    end if ! first or second order

!    deallocate(pstate)
    deallocate(R,Rtmp)

  end subroutine approximate_jacobian

end module nonlinear_algebra


*     SB08ED EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX, MMAX, PMAX
      PARAMETER        ( NMAX = 20, MMAX = 20, PMAX = 20 )
      INTEGER          MPMAX
      PARAMETER        ( MPMAX = MAX( MMAX, PMAX ) )
      INTEGER          LDA, LDB, LDBR, LDC, LDD, LDDR
      PARAMETER        ( LDA = NMAX, LDB = NMAX, LDC = MPMAX,
     $                   LDD = MPMAX, LDBR = NMAX, LDDR = PMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX*PMAX + MAX( NMAX*( NMAX + 5 ),
     $                                             5*PMAX, 4*MMAX ) )
*     .. Local Scalars ..
      DOUBLE PRECISION TOL
      INTEGER          I, INFO, IWARN, J, M, N, NQ, NR, P
      CHARACTER*1      DICO
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), ALPHA(2), B(LDB,MPMAX),
     $                 BR(LDBR,PMAX), C(LDC,NMAX), D(LDD,MPMAX),
     $                 DR(LDDR,PMAX), DWORK(LDWORK)
*     .. External Subroutines ..
      EXTERNAL         SB08ED
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, M, P, ALPHA(1), TOL, DICO
      ALPHA(2) = ALPHA(1)
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99990 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1, N ), I = 1, N )
         IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
            WRITE ( NOUT, FMT = 99989 ) M
         ELSE
            READ ( NIN, FMT = * ) ( ( B(I,J), J = 1, M ), I = 1, N )
            IF ( P.LT.0 .OR. P.GT.PMAX ) THEN
               WRITE ( NOUT, FMT = 99988 ) P
            ELSE
               READ ( NIN, FMT = * ) ( ( C(I,J), J = 1, N ), I = 1, P )
               READ ( NIN, FMT = * ) ( ( D(I,J), J = 1, M ), I = 1, P )
*              Find a LCF for (A,B,C,D).
               CALL SB08ED( DICO, N, M, P, ALPHA, A, LDA, B, LDB, C,
     $                      LDC, D, LDD, NQ, NR, BR, LDBR, DR, LDDR,
     $                      TOL, DWORK, LDWORK, IWARN, INFO )
*
               IF ( INFO.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99998 ) INFO
               ELSE
                  IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99996 )
                  DO 20 I = 1, NQ
                     WRITE ( NOUT, FMT = 99995 ) ( A(I,J), J = 1, NQ )
   20             CONTINUE
                  IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99993 )
                  DO 40 I = 1, NQ
                     WRITE ( NOUT, FMT = 99995 ) ( B(I,J), J = 1, M )
   40             CONTINUE
                  IF( NQ.GT.0 ) WRITE ( NOUT, FMT = 99992 )
                  DO 60 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( C(I,J), J = 1, NQ )
   60             CONTINUE
                  WRITE ( NOUT, FMT = 99991 )
                  DO 70 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( D(I,J), J = 1, M )
   70             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99986 )
                  DO 80 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 )
     $                     ( A(I,J), J = 1, NR )
   80             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99985 )
                  DO 90 I = 1, NR
                     WRITE ( NOUT, FMT = 99995 ) ( BR(I,J), J = 1, P )
   90             CONTINUE
                  IF( NR.GT.0 ) WRITE ( NOUT, FMT = 99984 )
                  DO 100 I = 1, P
                     WRITE ( NOUT, FMT = 99995 )
     $                     ( C(I,J), J = 1, NR )
  100             CONTINUE
                  WRITE ( NOUT, FMT = 99983 )
                  DO 110 I = 1, P
                     WRITE ( NOUT, FMT = 99995 ) ( DR(I,J), J = 1, P )
  110             CONTINUE
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' SB08ED EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from SB08ED = ',I2)
99996 FORMAT (/' The numerator state dynamics matrix AQ is ')
99995 FORMAT (20(1X,F8.4))
99993 FORMAT (/' The numerator input/state matrix BQ is ')
99992 FORMAT (/' The numerator state/output matrix CQ is ')
99991 FORMAT (/' The numerator input/output matrix DQ is ')
99990 FORMAT (/' N is out of range.',/' N = ',I5)
99989 FORMAT (/' M is out of range.',/' M = ',I5)
99988 FORMAT (/' P is out of range.',/' P = ',I5)
99986 FORMAT (/' The denominator state dynamics matrix AR is ')
99985 FORMAT (/' The denominator input/state matrix BR is ')
99984 FORMAT (/' The denominator state/output matrix CR is ')
99983 FORMAT (/' The denominator input/output matrix DR is ')
      END


      SUBROUTINE CPPT03( UPLO, N, A, AINV, WORK, LDWORK, RWORK, RCOND,
     $                   RESID )
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDWORK, N
      REAL               RCOND, RESID
*     ..
*     .. Array Arguments ..
      REAL               RWORK( * )
      COMPLEX            A( * ), AINV( * ), WORK( LDWORK, * )
*     ..
*
*  Purpose
*  =======
*
*  CPPT03 computes the residual for a Hermitian packed matrix times its
*  inverse:
*     norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ),
*  where EPS is the machine epsilon.
*
*  Arguments
*  ==========
*
*  UPLO    (input) CHARACTER*1
*          Specifies whether the upper or lower triangular part of the
*          Hermitian matrix A is stored:
*          = 'U':  Upper triangular
*          = 'L':  Lower triangular
*
*  N       (input) INTEGER
*          The number of rows and columns of the matrix A.  N >= 0.
*
*  A       (input) COMPLEX array, dimension (N*(N+1)/2)
*          The original Hermitian matrix A, stored as a packed
*          triangular matrix.
*
*  AINV    (input) COMPLEX array, dimension (N*(N+1)/2)
*          The (Hermitian) inverse of the matrix A, stored as a packed
*          triangular matrix.
*
*  WORK    (workspace) COMPLEX array, dimension (LDWORK,N)
*
*  LDWORK  (input) INTEGER
*          The leading dimension of the array WORK.  LDWORK >= max(1,N).
*
*  RWORK   (workspace) REAL array, dimension (N)
*
*  RCOND   (output) REAL
*          The reciprocal of the condition number of A, computed as
*          ( 1/norm(A) ) / norm(AINV).
*
*  RESID   (output) REAL
*          norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS )
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
      COMPLEX            CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J, JJ
      REAL               AINVNM, ANORM, EPS
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               CLANGE, CLANHP, SLAMCH
      EXTERNAL           LSAME, CLANGE, CLANHP, SLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          CONJG, REAL
*     ..
*     .. External Subroutines ..
      EXTERNAL           CCOPY, CHPMV
*     ..
*     .. Executable Statements ..
*
*     Quick exit if N = 0.
*
      IF( N.LE.0 ) THEN
         RCOND = ONE
         RESID = ZERO
         RETURN
      END IF
*
*     Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
*
      EPS = SLAMCH( 'Epsilon' )
      ANORM = CLANHP( '1', UPLO, N, A, RWORK )
      AINVNM = CLANHP( '1', UPLO, N, AINV, RWORK )
      IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
         RCOND = ZERO
         RESID = ONE / EPS
         RETURN
      END IF
      RCOND = ( ONE/ANORM ) / AINVNM
*
*     UPLO = 'U':
*     Copy the leading N-1 x N-1 submatrix of AINV to WORK(1:N,2:N) and
*     expand it to a full matrix, then multiply by A one column at a
*     time, moving the result one column to the left.
*
      IF( LSAME( UPLO, 'U' ) ) THEN
*
*        Copy AINV
*
         JJ = 1
         DO 20 J = 1, N - 1
            CALL CCOPY( J, AINV( JJ ), 1, WORK( 1, J+1 ), 1 )
            DO 10 I = 1, J - 1
               WORK( J, I+1 ) = CONJG( AINV( JJ+I-1 ) )
   10       CONTINUE
            JJ = JJ + J
   20    CONTINUE
         JJ = ( ( N-1 )*N ) / 2 + 1
         DO 30 I = 1, N - 1
            WORK( N, I+1 ) = CONJG( AINV( JJ+I-1 ) )
   30    CONTINUE
*
*        Multiply by A
*
         DO 40 J = 1, N - 1
            CALL CHPMV( 'Upper', N, -CONE, A, WORK( 1, J+1 ), 1, CZERO,
     $                  WORK( 1, J ), 1 )
   40    CONTINUE
         CALL CHPMV( 'Upper', N, -CONE, A, AINV( JJ ), 1, CZERO,
     $               WORK( 1, N ), 1 )
*
*     UPLO = 'L':
*     Copy the trailing N-1 x N-1 submatrix of AINV to WORK(1:N,1:N-1)
*     and multiply by A, moving each column to the right.
*
      ELSE
*
*        Copy AINV
*
         DO 50 I = 1, N - 1
            WORK( 1, I ) = CONJG( AINV( I+1 ) )
   50    CONTINUE
         JJ = N + 1
         DO 70 J = 2, N
            CALL CCOPY( N-J+1, AINV( JJ ), 1, WORK( J, J-1 ), 1 )
            DO 60 I = 1, N - J
               WORK( J, J+I-1 ) = CONJG( AINV( JJ+I ) )
   60       CONTINUE
            JJ = JJ + N - J + 1
   70    CONTINUE
*
*        Multiply by A
*
         DO 80 J = N, 2, -1
            CALL CHPMV( 'Lower', N, -CONE, A, WORK( 1, J-1 ), 1, CZERO,
     $                  WORK( 1, J ), 1 )
   80    CONTINUE
         CALL CHPMV( 'Lower', N, -CONE, A, AINV( 1 ), 1, CZERO,
     $               WORK( 1, 1 ), 1 )
*
      END IF
*
*     Add the identity matrix to WORK .
*
      DO 90 I = 1, N
         WORK( I, I ) = WORK( I, I ) + CONE
   90 CONTINUE
*
*     Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS)
*
      RESID = CLANGE( '1', N, N, WORK, LDWORK, RWORK )
*
      RESID = ( ( RESID*RCOND )/EPS ) / REAL( N )
*
      RETURN
*
*     End of CPPT03
*
      END


module model_reynolds_analogy
#include <messenger.h>
    use mod_kinds,          only: rk
    use mod_constants,      only: THREE, TWO
    use mod_fluid,          only: cp
    use type_model,         only: model_t
    use type_chidg_worker,  only: chidg_worker_t
    use DNAD_D
    implicit none

    !>  Reynolds' Analogy used to compute thermal conductivity.
    !!
    !!  Model Fields:
    !!      - Thermal Conductivity
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/9/2016
    !!
    !---------------------------------------------------------------------------------------
    type, extends(model_t)  :: reynolds_analogy_t

        real(rk)    :: Pr = 0.72_rk

    contains

        procedure   :: init
        procedure   :: compute

    end type reynolds_analogy_t
    !***************************************************************************************

contains

    !>  Initialize the model with a name and the model fields it is contributing to.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !---------------------------------------------------------------------------------------
    subroutine init(self)
        class(reynolds_analogy_t), intent(inout)   :: self

        call self%set_name('Reynolds Analogy')
        call self%set_dependency('f(Q-)')

        call self%add_model_field('Laminar Thermal Conductivity')

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

    !>  Routine for computing a viscosity contribution from Sutherland's Law.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   12/1/2016
    !!
    !--------------------------------------------------------------------------------------
    subroutine compute(self,worker)
        class(reynolds_analogy_t),  intent(in)      :: self
        type(chidg_worker_t),       intent(inout)   :: worker

        type(AD_D), dimension(:),   allocatable :: viscosity, thermal_conductivity

        !
        ! Interpolate solution to quadrature nodes
        !
        viscosity = worker%get_field('Laminar Viscosity','value')

        !
        ! Stokes' Hypothesis for the second coefficient of viscosity
        !
        thermal_conductivity = cp * viscosity / self%Pr

        !
        ! Contribute second coefficient of viscosity
        !
        call worker%store_model_field('Laminar Thermal Conductivity', 'value', thermal_conductivity)

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

end module model_reynolds_analogy


FUNCTION ran3(idum)
INTEGER*4 idum
INTEGER*4 MBIG,MSEED,MZ
REAL*8 ran3,FAC
PARAMETER (MBIG=1000000000,MSEED=161803398,MZ=0,FAC=1.d0/MBIG)
INTEGER*4 i,iff,ii,inext,inextp,k
INTEGER*4 mj,mk,ma(55)
SAVE iff,inext,inextp,ma
DATA iff /0/

if(idum.lt.0.or.iff.eq.0)then
  iff=1
  mj=MSEED-iabs(idum)
  mj=mod(mj,MBIG)
  ma(55)=mj
  mk=1
  do 11 i=1,54
    ii=mod(21*i,55)
    ma(ii)=mk
    mk=mj-mk
    if(mk.lt.MZ)mk=mk+MBIG
    mj=ma(ii)
11  continue
  do 13 k=1,4
    do 12 i=1,55
      ma(i)=ma(i)-ma(1+mod(i+30,55))
      if(ma(i).lt.MZ)ma(i)=ma(i)+MBIG
12    continue
13  continue
  inext=0
  inextp=31
  idum=1
endif

inext=inext+1
if(inext.eq.56)inext=1
inextp=inextp+1
if(inextp.eq.56)inextp=1
mj=ma(inext)-ma(inextp)
if(mj.lt.MZ)mj=mj+MBIG
ma(inext)=mj
ran3=mj*FAC

return
END