      SUBROUTINE IB01ND( METH, JOBD, NOBR, M, L, R, LDR, SV, TOL, IWORK,
     $                   DWORK, LDWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To find the singular value decomposition (SVD) giving the system
C     order, using the triangular factor of the concatenated block
C     Hankel matrices. Related preliminary calculations needed for
C     computing the system matrices are also performed.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     METH    CHARACTER*1
C             Specifies the subspace identification method to be used,
C             as follows:
C             = 'M':  MOESP  algorithm with past inputs and outputs;
C             = 'N':  N4SID  algorithm.
C
C     JOBD    CHARACTER*1
C             Specifies whether or not the matrices B and D should later
C             be computed using the MOESP approach, as follows:
C             = 'M':  the matrices B and D should later be computed
C                     using the MOESP approach;
C             = 'N':  the matrices B and D should not be computed using
C                     the MOESP approach.
C             This parameter is not relevant for METH = 'N'.
C
C     Input/Output Parameters
C
C     NOBR    (input) INTEGER
C             The number of block rows,  s,  in the input and output
C             block Hankel matrices.  NOBR > 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     L       (input) INTEGER
C             The number of system outputs.  L > 0.
C
C     R       (input/output) DOUBLE PRECISION array, dimension
C             ( LDR,2*(M+L)*NOBR )
C             On entry, the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper
C             triangular part of this array must contain the upper
C             triangular factor R from the QR factorization of the
C             concatenated block Hankel matrices. Denote  R_ij,
C             i,j = 1:4,  the ij submatrix of  R,  partitioned by
C             M*NOBR,  M*NOBR,  L*NOBR,  and  L*NOBR  rows and columns.
C             On exit, if INFO = 0, the leading
C             2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this
C             array contains the matrix S, the processed upper
C             triangular factor R, as required by other subroutines.
C             Specifically, let  S_ij, i,j = 1:4,  be the ij submatrix
C             of  S,  partitioned by  M*NOBR,  L*NOBR,  M*NOBR,  and
C             L*NOBR  rows and columns. The submatrix  S_22  contains
C             the matrix of left singular vectors needed subsequently.
C             Useful information is stored in  S_11  and in the
C             block-column  S_14 : S_44.  For METH = 'M' and JOBD = 'M',
C             the upper triangular part of  S_31  contains the upper
C             triangular factor in the QR factorization of the matrix
C             R_1c = [ R_12'  R_22'  R_11' ]',  and  S_12  contains the
C             corresponding leading part of the transformed matrix
C             R_2c = [ R_13'  R_23'  R_14' ]'.  For  METH = 'N',  the
C             subarray  S_41 : S_43  contains the transpose of the
C             matrix contained in  S_14 : S_34.
C
C     LDR     INTEGER
C             The leading dimension of the array  R.
C             LDR >= MAX( 2*(M+L)*NOBR, 3*M*NOBR ),
C                                  for METH = 'M' and JOBD = 'M';
C             LDR >= 2*(M+L)*NOBR, for METH = 'M' and JOBD = 'N' or
C                                  for METH = 'N'.
C
C     SV      (output) DOUBLE PRECISION array, dimension ( L*NOBR )
C             The singular values of the relevant part of the triangular
C             factor from the QR factorization of the concatenated block
C             Hankel matrices.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used for estimating the rank of
C             matrices. If the user sets  TOL > 0,  then the given value
C             of  TOL  is used as a lower bound for the reciprocal
C             condition number;  an m-by-n matrix whose estimated
C             condition number is less than  1/TOL  is considered to
C             be of full rank.  If the user sets  TOL <= 0,  then an
C             implicitly computed, default tolerance, defined by
C             TOLDEF = m*n*EPS,  is used instead, where  EPS  is the
C             relative machine precision (see LAPACK Library routine
C             DLAMCH).
C             This parameter is not used for  METH = 'M'.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension ((M+L)*NOBR)
C             This parameter is not referenced for METH = 'M'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if  INFO = 0,  DWORK(1) returns the optimal value
C             of LDWORK,  and, for  METH = 'N',  DWORK(2)  and  DWORK(3)
C             contain the reciprocal condition numbers of the
C             triangular factors of the matrices  U_f  and  r_1  [6].
C             On exit, if  INFO = -12,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= max( (2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR ),
C                                         if METH = 'M' and JOBD = 'M';
C             LDWORK >=  5*L*NOBR,        if METH = 'M' and JOBD = 'N';
C             LDWORK >=  5*(M+L)*NOBR+1,  if METH = 'N'.
C             For good performance,  LDWORK  should be larger.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 4:  the least squares problems with coefficient matrix
C                   U_f,  used for computing the weighted oblique
C                   projection (for METH = 'N'), have a rank-deficient
C                   coefficient matrix;
C             = 5:  the least squares problem with coefficient matrix
C                   r_1  [6], used for computing the weighted oblique
C                   projection (for METH = 'N'), has a rank-deficient
C                   coefficient matrix.
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             = 2:  the singular value decomposition (SVD) algorithm did
C                   not converge.
C
C     METHOD
C
C     A singular value decomposition (SVD) of a certain matrix is
C     computed, which reveals the order  n  of the system as the number
C     of "non-zero" singular values. For the MOESP approach, this matrix
C     is  [ R_24'  R_34' ]' := R(ms+1:(2m+l)s,(2m+l)s+1:2(m+l)s),
C     where  R  is the upper triangular factor  R  constructed by SLICOT
C     Library routine  IB01MD.  For the N4SID approach, a weighted
C     oblique projection is computed from the upper triangular factor  R
C     and its SVD is then found.
C
C     REFERENCES
C
C     [1] Verhaegen M., and Dewilde, P.
C         Subspace Model Identification. Part 1: The output-error
C         state-space model identification class of algorithms.
C         Int. J. Control, 56, pp. 1187-1210, 1992.
C
C     [2] Verhaegen M.
C         Subspace Model Identification. Part 3: Analysis of the
C         ordinary output-error state-space model identification
C         algorithm.
C         Int. J. Control, 58, pp. 555-586, 1993.
C
C     [3] Verhaegen M.
C         Identification of the deterministic part of MIMO state space
C         models given in innovations form from input-output data.
C         Automatica, Vol.30, No.1, pp.61-74, 1994.
C
C     [4] Van Overschee, P., and De Moor, B.
C         N4SID: Subspace Algorithms for the Identification of
C         Combined Deterministic-Stochastic Systems.
C         Automatica, Vol.30, No.1, pp. 75-93, 1994.
C
C     [5] Van Overschee, P., and De Moor, B.
C         Subspace Identification for Linear Systems: Theory -
C         Implementation - Applications.
C         Kluwer Academic Publishers, Boston/London/Dordrecht, 1996.
C
C     [6] Sima, V.
C         Subspace-based Algorithms for Multivariable System
C         Identification.
C         Studies in Informatics and Control, 5, pp. 335-344, 1996.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically stable.
C                                      3
C     The algorithm requires 0(((m+l)s) ) floating point operations.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999.
C
C     REVISIONS
C
C     Feb. 2000, Feb. 2001, Feb. 2004, March 2005.
C
C     KEYWORDS
C
C     Identification methods, multivariable systems, QR decomposition,
C     singular value decomposition.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TWO, THREE
      PARAMETER          ( ZERO  = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
     $                     THREE = 3.0D0 )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   TOL
      INTEGER            INFO, IWARN, L, LDR, LDWORK, M, NOBR
      CHARACTER          JOBD, METH
C     .. Array Arguments ..
      DOUBLE PRECISION   DWORK(*), R(LDR, *), SV(*)
      INTEGER            IWORK(*)
C     .. Local Scalars ..
      DOUBLE PRECISION   EPS, RCOND1, RCOND2, SVLMAX, THRESH, TOLL
      INTEGER            I, IERR, ITAU, ITAU2, ITAU3, J, JWORK, LLMNOB,
     $                   LLNOBR, LMMNOB, LMNOBR, LNOBR, MAXWRK, MINWRK,
     $                   MMNOBR, MNOBR, NR, NR2, NR3, NR4, NRSAVE, RANK,
     $                   RANK1
      LOGICAL            JOBDM, MOESP, N4SID
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM(1), SVAL(3)
C     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH, ILAENV, LSAME
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DGEQRF, DLACPY, DLASET, DORMQR, DSWAP,
     $                   DTRCON, MA02AD, MB03OD, MB03UD, MB04ID, MB04IY,
     $                   MB04OD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX
C     ..
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      MOESP  = LSAME( METH, 'M' )
      N4SID  = LSAME( METH, 'N' )
      JOBDM  = LSAME( JOBD, 'M' )
      MNOBR  = M*NOBR
      LNOBR  = L*NOBR
      LLNOBR = LNOBR + LNOBR
      LMNOBR = LNOBR + MNOBR
      MMNOBR = MNOBR + MNOBR
      LMMNOB = MMNOBR + LNOBR
      NR     = LMNOBR + LMNOBR
      IWARN  = 0
      INFO   = 0
C
C     Check the scalar input parameters.
C
      IF( .NOT.( MOESP .OR. N4SID ) ) THEN
         INFO = -1
      ELSE IF( MOESP .AND. .NOT.( JOBDM .OR. LSAME( JOBD, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( NOBR.LE.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( L.LE.0 ) THEN
         INFO = -5
      ELSE IF( LDR.LT.NR .OR. ( MOESP .AND. JOBDM .AND.
     $         LDR.LT.3*MNOBR ) ) THEN
         INFO = -7
      ELSE
C
C        Compute workspace.
C        (Note: Comments in the code beginning "Workspace:" describe the
C         minimal amount of workspace needed at that point in the code,
C         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
         MINWRK = 1
         IF ( LDWORK.GE.1 ) THEN
            IF ( MOESP ) THEN
               MINWRK = 5*LNOBR
               IF ( JOBDM )
     $            MINWRK = MAX( MMNOBR - NOBR, LMNOBR, MINWRK )
               MAXWRK = LNOBR + LNOBR*ILAENV( 1, 'DGEQRF', ' ', LMNOBR,
     $                                        LNOBR, -1, -1 )
            ELSE
C
               MINWRK = MAX( MINWRK, 5*LMNOBR + 1 )
               MAXWRK = MAX( MNOBR + MNOBR*ILAENV( 1, 'DGEQRF', ' ',
     $                                 MMNOBR, MNOBR, -1, -1 ),
     $                       MNOBR + LLNOBR*ILAENV( 1, 'DORMQR', 'LT',
     $                                 MMNOBR, LLNOBR, MNOBR, -1 ) )
               MAXWRK = MAX( MAXWRK, MNOBR + LNOBR*ILAENV( 1, 'DORMQR',
     $                                 'LN', MMNOBR, LNOBR, MNOBR,
     $                                 -1 ) )
               MAXWRK = MAX( MAXWRK, LNOBR + LNOBR*ILAENV( 1, 'DGEQRF',
     $                                  ' ', LMMNOB, LNOBR, -1, -1 ) )
            END IF
            MAXWRK = MAX( MINWRK, MAXWRK )
         END IF
C
         IF( LDWORK.LT.MINWRK ) THEN
            INFO = -12
            DWORK( 1 ) = MINWRK
         END IF
      END IF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'IB01ND', -INFO )
         RETURN
      END IF
C
C     Compute pointers to the needed blocks of  R.
C
      NR2   = MNOBR  + 1
      NR3   = MMNOBR + 1
      NR4   = LMMNOB + 1
      ITAU  = 1
      JWORK = ITAU + MNOBR
C
      IF( MOESP ) THEN
C
C        MOESP approach.
C
         IF( M.GT.0 .AND. JOBDM ) THEN
C
C           Rearrange the blocks of  R:
C           Copy the (1,1) block into the position (3,2) and
C           copy the (1,4) block into (3,3).
C
            CALL DLACPY( 'Upper', MNOBR, MNOBR, R, LDR, R(NR3,NR2),
     $                   LDR )
            CALL DLACPY( 'Full',  MNOBR, LNOBR, R(1,NR4), LDR,
     $                   R(NR3,NR3), LDR )
C
C           Using structure, triangularize the matrix
C              R_1c = [ R_12'  R_22'  R_11' ]'
C           and then apply the transformations to the matrix
c              R_2c = [ R_13'  R_23'  R_14' ]'.
C           Workspace: need M*NOBR + MAX(M-1,L)*NOBR.
C
            CALL MB04OD( 'Upper', MNOBR, LNOBR, MNOBR, R(NR2,NR2), LDR,
     $                   R(NR3,NR2), LDR, R(NR2,NR3), LDR, R(NR3,NR3),
     $                   LDR, DWORK(ITAU), DWORK(JWORK) )
            CALL MB04ID( MMNOBR, MNOBR, MNOBR-1, LNOBR, R(1,NR2), LDR,
     $                   R(1,NR3), LDR, DWORK(ITAU), DWORK(JWORK),
     $                   LDWORK-JWORK+1, IERR )
            MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
C
C           Copy the leading  M*NOBR x M*NOBR  and  M*NOBR x L*NOBR
C           submatrices of  R_1c  and  R_2c,  respectively, into their
C           final positions, required by SLICOT Library routine  IB01PD.
C
            CALL DLACPY( 'Upper', MNOBR, MNOBR, R(1,NR2), LDR,
     $                   R(LMNOBR+1,1), LDR )
            CALL DLACPY( 'Full',  MNOBR, LNOBR, R(1,NR3), LDR, R(1,NR2),
     $                   LDR )
         END IF
C
C        Copy [ R_24'  R_34' ]'  in  [ R_22'  R_32' ]'.
C
         CALL DLACPY( 'Full', LMNOBR, LNOBR, R(NR2,NR4), LDR,
     $                R(NR2,NR2), LDR )
C
C        Triangularize the matrix in  [ R_22'  R_32' ]'.
C        Workspace: need 2*L*NOBR; prefer L*NOBR + L*NOBR*NB.
C
         JWORK = ITAU + LNOBR
         CALL DGEQRF( LMNOBR, LNOBR, R(NR2,NR2), LDR, DWORK(ITAU),
     $                DWORK(JWORK), LDWORK-JWORK+1, IERR )
C
      ELSE
C
C        N4SID approach.
C
         DUM(1) = ZERO
         LLMNOB = LLNOBR + MNOBR
C
C        Set the precision parameters. A threshold value  EPS**(2/3)  is
C        used for deciding to use pivoting or not, where  EPS  is the
C        relative machine precision (see LAPACK Library routine DLAMCH).
C
         TOLL   = TOL
         EPS    = DLAMCH( 'Precision' )
         THRESH = EPS**( TWO/THREE )
C
         IF( M.GT.0 ) THEN
C
C           For efficiency of later calculations, interchange the first
C           two block-columns. The corresponding submatrices are
C           redefined according to their new position.
C
            DO 10 I = 1, MNOBR
               CALL DSWAP( I, R(1,I), 1, R(1,MNOBR+I), 1 )
               CALL DCOPY( MNOBR, R(I+1,MNOBR+I), 1, R(I+1,I), 1 )
               CALL DCOPY( MMNOBR-I, DUM, 0, R(I+1,MNOBR+I), 1 )
   10       CONTINUE
C
C           Now,
C
C           U_f = [ R_11'  R_21'    0      0   ]',
C           U_p = [ R_12'    0      0      0   ]',
C           Y_p = [ R_13'  R_23'  R_33'    0   ]',  and
C           Y_f = [ R_14'  R_24'  R_34'  R_44' ]',
C
C           where  R_21,  R_12,  R_33,  and  R_44  are upper triangular.
C           Define  W_p := [ U_p  Y_p ].
C
C           Prepare the computation of residuals of the two least
C           squares problems giving the weighted oblique projection P:
C
C           r_1 = W_p - U_f X_1,   X_1 = arg min || U_f X - W_p ||,
C           r_2 = Y_f - U_f X_2,   X_2 = arg min || U_f X - Y_f ||,
C
C           P = (arg min || r_1 X - r_2 ||)' r_1'.                   (1)
C
C           Alternately,  P'  is given by the projection
C              P' = Q_1 (Q_1)' r_2,
C           where  Q_1  contains the first  k  columns of the orthogonal
C           matrix in the  QR  factorization of  r_1,  k := rank(r_1).
C
C           Triangularize the matrix  U_f = q r  (using structure), and
C           apply the transformation  q'  to the corresponding part of
C           the matrices  W_p,  and  Y_f.
C           Workspace: need 2*(M+L)*NOBR.
C
            CALL MB04ID( MMNOBR, MNOBR, MNOBR-1, LLMNOB, R, LDR,
     $                   R(1,NR2), LDR, DWORK(ITAU), DWORK(JWORK),
     $                   LDWORK-JWORK+1, IERR )
            MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
C
C           Save updated  Y_f  (transposed) in the last block-row of  R.
C
            CALL MA02AD( 'Full', LMMNOB, LNOBR, R(1,NR4), LDR, R(NR4,1),
     $                   LDR )
C
C           Check the condition of the triangular factor  r  and decide
C           to use pivoting or not.
C           Workspace: need 4*M*NOBR.
C
            CALL DTRCON( '1-norm', 'Upper', 'NonUnit', MNOBR, R, LDR,
     $                   RCOND1, DWORK(JWORK), IWORK, IERR )
C
            IF( TOLL.LE.ZERO )
     $         TOLL = MNOBR*MNOBR*EPS
            IF ( RCOND1.GT.MAX( TOLL, THRESH ) ) THEN
C
C              U_f is considered full rank and no pivoting is used.
C
               CALL DLASET( 'Full', MNOBR, LLMNOB, ZERO, ZERO, R(1,NR2),
     $                      LDR )
            ELSE
C
C              Save information about  q  in the (2,1) block of  R.
C              Use QR factorization with column pivoting,  r P = Q R.
C              Information on  Q  is stored in the strict lower triangle
C              of R_11  and in  DWORK(ITAU2).
C
               DO 20 I = 1, MNOBR - 1
                  DO 15 J = MMNOBR, NR2, -1
                     R(J,I) = R(J-MNOBR+I,I)
   15             CONTINUE
                  CALL DCOPY( MNOBR-I, DUM, 0, R(I+1,I), 1 )
                  IWORK(I) = 0
   20          CONTINUE
C
               IWORK(MNOBR) = 0
C
C              Workspace: need   5*M*NOBR+1.
C                         prefer 4*M*NOBR + (M*NOBR+1)*NB.
C
               ITAU2  = JWORK
               JWORK  = ITAU2 + MNOBR
               SVLMAX = ZERO
               CALL MB03OD( 'QR', MNOBR, MNOBR, R, LDR, IWORK, TOLL,
     $                      SVLMAX, DWORK(ITAU2), RANK, SVAL,
     $                      DWORK(JWORK), LDWORK-JWORK+1, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
C
C              Workspace: need   2*M*NOBR + (M+2*L)*NOBR;
C                         prefer 2*M*NOBR + (M+2*L)*NOBR*NB.
C
               CALL DORMQR( 'Left', 'Transpose', MNOBR, LLMNOB, MNOBR,
     $                      R, LDR, DWORK(ITAU2), R(1,NR2), LDR,
     $                      DWORK(JWORK), LDWORK-JWORK+1, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
               IF ( RANK.LT.MNOBR ) THEN
C
C                 The least squares problem is rank-deficient.
C
                  IWARN = 4
               END IF
C
C              Determine residuals r_1 and r_2: premultiply by  Q  and
C              then by  q.
C              Workspace: need   2*M*NOBR + (M+2*L)*NOBR);
C                         prefer 2*M*NOBR + (M+2*L)*NOBR*NB.
C
               CALL DLASET( 'Full', RANK, LLMNOB, ZERO, ZERO, R(1,NR2),
     $                      LDR )
               CALL DORMQR( 'Left', 'NoTranspose', MNOBR, LLMNOB, MNOBR,
     $                      R, LDR, DWORK(ITAU2), R(1,NR2), LDR,
     $                      DWORK(JWORK), LDWORK-JWORK+1, IERR )
               MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
               JWORK  = ITAU2
C
C              Restore the transformation  q.
C
               DO 30 I = 1, MNOBR - 1
                  DO 25 J = NR2, MMNOBR
                     R(J-MNOBR+I,I) = R(J,I)
   25             CONTINUE
   30          CONTINUE
C
            END IF
C
C           Premultiply by the transformation  q  (apply transformations
C           in backward order).
C           Workspace: need   M*NOBR + (M+2*L)*NOBR;
C                      prefer larger.
C
            CALL MB04IY( 'Left', 'NoTranspose', MMNOBR, LLMNOB, MNOBR,
     $                   MNOBR-1, R, LDR, DWORK(ITAU), R(1,NR2), LDR,
     $                   DWORK(JWORK), LDWORK-JWORK+1, IERR )
            MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
C
         ELSE
C
C           Save  Y_f  (transposed) in the last block-row of  R.
C
            CALL MA02AD( 'Full', LMMNOB, LNOBR, R(1,NR4), LDR, R(NR4,1),
     $                   LDR )
            RCOND1 = ONE
         END IF
C
C        Triangularize the matrix  r_1  for determining the oblique
C        projection  P  in least squares problem in (1).  Exploit the
C        fact that the third block-row of r_1  has the structure
C        [ 0  T ],  where  T  is an upper triangular matrix.  Then apply
C        the corresponding transformations  Q'  to the matrix  r_2.
C        Workspace: need   2*M*NOBR;
C                   prefer   M*NOBR + M*NOBR*NB.
C
         CALL DGEQRF( MMNOBR, MNOBR, R(1,NR2), LDR, DWORK(ITAU),
     $                DWORK(JWORK), LDWORK-JWORK+1, IERR )
C
C        Workspace: need   M*NOBR + 2*L*NOBR;
C                   prefer M*NOBR + 2*L*NOBR*NB.
C
         CALL DORMQR( 'Left', 'Transpose', MMNOBR, LLNOBR, MNOBR,
     $                R(1,NR2), LDR, DWORK(ITAU), R(1,NR3), LDR,
     $                DWORK(JWORK), LDWORK-JWORK+1, IERR )
         NRSAVE = NR2
C
         ITAU2 = JWORK
         JWORK = ITAU2 + LNOBR
         CALL MB04ID( LMNOBR, LNOBR, LNOBR-1, LNOBR, R(NR2,NR3), LDR,
     $                R(NR2,NR4), LDR, DWORK(ITAU2), DWORK(JWORK),
     $                LDWORK-JWORK+1, IERR )
         MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
C
C        Check the condition of the triangular matrix of order  (m+l)*s
C        just determined, and decide to use pivoting or not.
C        Workspace: need 4*(M+L)*NOBR.
C
         CALL DTRCON( '1-norm', 'Upper', 'NonUnit', LMNOBR, R(1,NR2),
     $                LDR, RCOND2, DWORK(JWORK), IWORK, IERR )
C
         IF( TOL.LE.ZERO )
     $      TOLL = LMNOBR*LMNOBR*EPS
         IF ( RCOND2.LE.MAX( TOLL, THRESH ) ) THEN
            IF ( M.GT.0 ) THEN
C
C              Save information about  Q  in  R_11  (in the strict lower
C              triangle),  R_21  and  R_31  (transposed information).
C
               CALL DLACPY( 'Lower', MMNOBR-1, MNOBR, R(2,NR2), LDR,
     $                      R(2,1), LDR )
               NRSAVE = 1
C
               DO 40 I = NR2, LMNOBR
                  CALL DCOPY( MNOBR, R(I+1,MNOBR+I), 1, R(MNOBR+I,1),
     $                        LDR )
   40          CONTINUE
C
            END IF
C
            CALL DLASET( 'Lower', LMNOBR-1, LMNOBR-1, ZERO, ZERO,
     $                   R(2,NR2), LDR )
C
C           Use QR factorization with column pivoting.
C           Workspace: need   5*(M+L)*NOBR+1.
C                      prefer 4*(M+L)*NOBR + ((M+L)*NOBR+1)*NB.
C
            DO 50 I = 1, LMNOBR
               IWORK(I) = 0
   50       CONTINUE
C
            ITAU3  = JWORK
            JWORK  = ITAU3 + LMNOBR
            SVLMAX = ZERO
            CALL MB03OD( 'QR', LMNOBR, LMNOBR, R(1,NR2), LDR, IWORK,
     $                   TOLL, SVLMAX, DWORK(ITAU3), RANK1, SVAL,
     $                   DWORK(JWORK), LDWORK-JWORK+1, IERR )
            MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
C
C           Workspace: need   2*(M+L)*NOBR + L*NOBR;
C                      prefer 2*(M+L)*NOBR + L*NOBR*NB.
C
            CALL DORMQR( 'Left', 'Transpose', LMNOBR, LNOBR, LMNOBR,
     $                   R(1,NR2), LDR, DWORK(ITAU3), R(1,NR4), LDR,
     $                   DWORK(JWORK), LDWORK-JWORK+1, IERR )
            MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
            IF ( RANK1.LT.LMNOBR ) THEN
C
C              The least squares problem is rank-deficient.
C
               IWARN = 5
            END IF
C
C           Apply the orthogonal transformations, in backward order, to
C           [r_2(1:rank(r_1),:)' 0]',  to obtain  P'.
C           Workspace: need   2*(M+L)*NOBR + L*NOBR;
C                      prefer 2*(M+L)*NOBR + L*NOBR*NB.
C
            CALL DLASET( 'Full', LMNOBR-RANK1, LNOBR, ZERO, ZERO,
     $                   R(RANK1+1,NR4), LDR )
            CALL DORMQR( 'Left', 'NoTranspose', LMNOBR, LNOBR, LMNOBR,
     $                   R(1,NR2), LDR, DWORK(ITAU3), R(1,NR4), LDR,
     $                   DWORK(JWORK), LDWORK-JWORK+1, IERR )
            MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
            JWORK = ITAU3
C
            IF ( M.GT.0 ) THEN
C
C              Restore the saved transpose matrix from  R_31.
C
               DO 60 I = NR2, LMNOBR
                  CALL DCOPY( MNOBR, R(MNOBR+I,1), LDR, R(I+1,MNOBR+I),
     $                        1 )
   60          CONTINUE
C
            END IF
C
         END IF
C
C        Workspace: need   M*NOBR + L*NOBR;
C                   prefer larger.
C
         CALL MB04IY( 'Left', 'NoTranspose', LMNOBR, LNOBR, LNOBR,
     $                LNOBR-1, R(NR2,NR3), LDR, DWORK(ITAU2),
     $                R(NR2,NR4), LDR, DWORK(JWORK), LDWORK-JWORK+1,
     $                IERR )
         MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
C
C        Workspace: need   M*NOBR + L*NOBR;
C                   prefer M*NOBR + L*NOBR*NB.
C
         JWORK = ITAU2
         CALL DORMQR( 'Left', 'NoTranspose', MMNOBR, LNOBR, MNOBR,
     $                R(1,NRSAVE), LDR, DWORK(ITAU), R(1,NR4), LDR,
     $                DWORK(JWORK), LDWORK-JWORK+1, IERR )
C
C        Now, the matrix  P'  is available in  R_14 : R_34.
C        Triangularize the matrix  P'.
C        Workspace: need   2*L*NOBR;
C                   prefer   L*NOBR + L*NOBR*NB.
C
         JWORK = ITAU + LNOBR
         CALL DGEQRF( LMMNOB, LNOBR, R(1,NR4), LDR, DWORK(ITAU),
     $                DWORK(JWORK), LDWORK-JWORK+1, IERR )
C
C        Copy the triangular factor to its final position,  R_22.
C
         CALL DLACPY( 'Upper', LNOBR, LNOBR, R(1,NR4), LDR, R(NR2,NR2),
     $                LDR )
C
C        Restore  Y_f.
C
         CALL MA02AD( 'Full', LNOBR, LMMNOB, R(NR4,1), LDR, R(1,NR4),
     $                LDR )
      END IF
C
C     Find the singular value decomposition of  R_22.
C     Workspace: need 5*L*NOBR.
C
      CALL MB03UD( 'NoVectors', 'Vectors', LNOBR, R(NR2,NR2), LDR,
     $             DUM, 1, SV, DWORK, LDWORK, IERR )
      IF ( IERR.NE.0 ) THEN
         INFO = 2
         RETURN
      END IF
      MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
C
C     Transpose  R(m*s+1:(m+L)*s,m*s+1:(m+L)*s)  in-situ; its
C     columns will then be the singular vectors needed subsequently.
C
      DO 70 I = NR2+1, LMNOBR
         CALL DSWAP( LMNOBR-I+1, R(I,I-1), 1, R(I-1,I), LDR )
   70 CONTINUE
C
C     Return optimal workspace in  DWORK(1)  and reciprocal condition
C     numbers, if  METH = 'N'.
C
      DWORK(1) = MAXWRK
      IF ( N4SID ) THEN
         DWORK(2) = RCOND1
         DWORK(3) = RCOND2
      END IF
      RETURN
C
C *** Last line of IB01ND ***
      END


	!> Element for pos processing variables and store in Param
	!! @param CommonPar = ( ... , a, a*[bi,ci]) where :
	!! @param iShiftU = CommonPar(1)
	!! @param iFemType = CommonPar(2)
	!! @param iFtype = CommonPar(3)
	!! @param iMaterial = CommonPar(4)
	!! @param iDamageParType = CommonPar(5)
	!! @param Nelem = CommonPar(6)
	!! @param NFields = CommonPar(7)  ===> a
	!! @param CodeField(i) = CommonPar(see structure) ==> bi
	!! @param PosField(i) = CommonPar(see structure) ==> ci
	!! @author Rocha, Felipe Figueredo

 Subroutine posProcElem(AE, BE, MaxLRows, XLL, NDim, iDofT, NodElt, Sol0, Sol1, CommonPar, Param, JParam, DelT, DTm, Time)
!     ------------------------------------------------------------------
	use funcAux
	use finiteStrainLib !! New way
	use damageNewLib
	use multiscaleLib
	use globalVariables, only : getF, NdimE, getDamagePar, getMaterial, maxDamagePar, maxMatPar, &
								addVol
	use ptsGaussLib

	implicit none

	!   ===== SUBROUTINE ARGUMENTS  =======
	integer :: MaxLRows,Ndim,iDofT,NodElt ! all integers
	Real*8 :: DelT, DTm,Time ! all reals
	Real*8 :: AE(MaxLRows,MaxLRows), BE(MaxLRows), XLL(*), Sol0(*), Sol1(*), Param(*), JParam(*), CommonPar(*)

	!   =====   END ARGUMENTS  =======

	Integer :: nG, i! counters
	Integer , parameter :: iShiftField = 8,  NFieldPar = 2
	Real*8 :: GradU(NdimE,NdimE) , F(NdimE,NdimE), NvecP(3)
	Real*8 :: PK(NdimE,NdimE), D(NdimE,NdimE,NdimE,NdimE), sigma(NdimE,NdimE) , detF, p_ng
	Real*8 :: MatPar(maxMatPar) ,  damagePar(maxDamagePar), VField(4) , energy, energyMean, dV
	real*8 , allocatable :: SolU(:) ,  Xel(:) , SolP(:)
	integer :: pOrderU , pOrderP, NGP, NodGU, NodGP, iFEMtypeU , iFEMtypeP, iShiftU, iShiftP
	integer :: constlaw, iFemType,  iSimplex,  iBubble, iFtype, iMaterial, iDamageParType , NFields, CodeField(5) , PosField(5) !! maximum 5 at now
	type(ptGaussClass) :: PtGU, PtGP

	matPar = 0.0d0

	iShiftU= nint(commonPar(1))
	iFemTypeU = nint(commonPar(2))
	iShiftP= nint(commonPar(3))
	iFemTypeP = nint(commonPar(4))
	iFtype = nint(commonPar(5))
	iMaterial = nint(commonPar(6))
	iDamageParType = nint(commonPar(7))
	NFields = nint(CommonPar(8))
	do i = 1, NFields
		CodeField(i) = nint(CommonPar( iShiftField + (i-1)*NFieldPar + 1) )
		PosField(i)  = nint(CommonPar( iShiftField + (i-1)*NFieldPar + 2) )
	end do

	if(iDamageParType > 0) call getDamagePar(damagePar,iDamageParType)
	call getMaterial(constLaw, matPar, iMaterial)
	call setFEMtype(iFEMtypeU,NodGU,pOrderU,NGP,iSimplex,iBubble)
	call setFEMtype(iFEMtypeP,NodGP,pOrderP,NGP,iSimplex,iBubble)

	call getSliceAllocate(SolU,Sol1,1,NodGU,iShiftU + 1 ,iShiftU + NdimE, iDofT)
	call getSliceAllocate(Xel,XLL,1,NodGU,1 ,NdimE, Ndim)
	call getSliceAllocate(SolP,Sol1,1,NodGP,iShiftP + 1 ,iShiftP + 1, iDofT)

	NGP = 1
	nG = 1

	call PtGU%init(Xel,NodGU,NdimE,NGP,pOrderU,iBubble, iSimplex)
	call PtGP%init(Xel,NodGP,NdimE,NGP,pOrderP,iBubble, iSimplex)

	call PtGU%calcGradU(GradU,SolU,nG)
	call getF(F,iFtype)
	F = F + GradU
	call calcPpk(PK,F,NdimE,matPar,constLaw)
	call calcD(D,F,NdimE,matPar,constLaw)
!~ 	if(iDamageParType > 0) call damageModifyTangent(D,PK,damagePar,Param,nG, 4) ! deprecated
	call strainEnergy(energy,F,matPar,constLaw)

	call PtGP%getNvecScalar(NvecP,nG)
	P_ng = dot_product(NvecP,SolP)

	call MatDet(detF,F)

	sigma = (1.0d0/detF)*matmul(PK,transpose(F)) + p_ng*deltaKron(1:NdimE,1:NdimE)

	dV=ptGU%dV(nG)

	do i = 1 , NFields
		select case(CodeField(i))
			case(1) !! energy
				VField(i) = energy
			case(2) !! vol
				VField(i) = dV
			case(3) !! sigmaXX
				VField(i) = sigma(1,1)
			case(4) !! sigmaYY
				VField(i) = sigma(2,2)
			case(5) !! sigmaXY
				VField(i) = sigma(1,2)
			case(6) !! pressure
				VField(i) = P_ng
			case(7) !! detF
				VField(i) = detF
			case(8) !! assimetry
				VField(i) = sigma(2,1) - sigma(1,2)
			case(11) !! P11
				VField(i) = PK(1,1)
			case(12) !! P12
				VField(i) = PK(1,2)
			case(13) !! P21
				VField(i) = PK(2,1)
			case(14) !! P22
				VField(i) = PK(2,2)

			case default
				write(0,*) "Code Field not found"
				VField(i) = 0
		end select

!~ 		write(0,*) "=============> PK =", VField(i)
		Param(LengthParam + PosField(i) ) = VField(i)

	end do

	AE(1,1) = 1.0d0
	BE(1) = Sol1(1)

End Subroutine

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine posProcElemS(Coupling,CommonPar,iDofT,Ndim,MaxLRows,iAdd)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	IMPLICIT NONE
	Integer :: MaxLRows,Ndim,iDofT, iAdd, ipRow , i
	Integer   Coupling(MaxLRows,MaxLRows)
	Real*8 CommonPar(*)

	Coupling=0

	Coupling(1,1) = 1

	return
end Subroutine


!----------------------------------------------------------------------
      subroutine precal
!................................................................
c                                                             01/01/89
c     purpose:
c     Calculate everything that does not need pot.coeffs, e.g.
c     surface and fft stuff
c................................................................
      use Vmeshes
      use NumParams
      use LoopCtrl
      USE Vprecal1
      USE Vprecal2
      USE Vprecal3
      USE Vprecal4
      USE Vprecal5
      USE Vprecal6, ONLY: comu, simu
      USE Vprecal7, ONLY: conv, sinv
      USE Vprecal8, ONLY: coh1, sih1
      USE Vprecal9, ONLY: comu1, simu1
      USE Vprecal10, ONLY: conv1, sinv1
      USE Vfourier2
      implicit none
c................................................................
C   L o c a l   V a r i a b l e s
c................................................................
      integer :: k, m, ku, n, kv, i
c................................................................
c
      i=0
      if (.not.allocated(trigs))
     1 allocate (trigs(2*nu), trigsv(2*nv), conv1(nv1,0:nd),
     1   sinv1(nv1,0:nd), comu(nu,0:md), simu(nu,0:md), factor(nuvh1),
     2   coh(nv), sih(nv), conv(nv,0:nd), sinv(nv,0:nd), coh1(nv1),
     3   sih1(nv1), comu1(nu1,0:md), simu1(nu1,0:md), eps(0:md + nd),
     4   stat = i)
      if (i .ne. 0) stop 'allocation error in NESCOIL precal'

      alp  = pi2/np
      alu  = pi2/nu
      alv  = pi2/nv
      alvp = pi2/(nv*np)
      fnuv = one/nuv
      fnv  = one/nv
      alu1 = pi2/nu1
      alv1 = pi2/nv1
      alvp1 = pi2/(nv1*np)
      fnuv1 = one/nuv1
      fnv1  = one/nv1
      call fftfax_g (nu, ifax, trigs)
      call cftfax_g (nv, ifaxv, trigsv)
      do 10 k=0,np-1
         cok(k) = cos(alp* k)
         sik(k) = sin(alp* k)
   10 continue
      do 20 m=0,md
      do 20 ku=1,nu
         comu(ku,m)   = cos(m*alu*(ku-1))
         simu(ku,m)   = sin(m*alu*(ku-1))
   20 continue
      do 30 n=0,nd
      do 30 kv=1,nv
         conv(kv,n)   = cos(n*alv*(kv-1))
         sinv(kv,n)   = sin(n*alv*(kv-1))
   30 continue
      do 40 kv=1,nv
         coh(kv)= cos(alvp*(kv-1))
         sih(kv)= sin(alvp*(kv-1))
   40 continue
      do 50 m=0,md
      do 50 ku=1,nu1
         comu1(ku,m)   = cos(m*alu1*(ku-1))
         simu1(ku,m)   = sin(m*alu1*(ku-1))
   50 continue
      do 60 n=0,nd
      do 60 kv=1,nv1
         conv1(kv,n)   = cos(n*alv1*(kv-1))
         sinv1(kv,n)   = sin(n*alv1*(kv-1))
   60 continue
      do 70 kv=1,nv1
         coh1(kv)= cos(alvp1*(kv-1))
         sih1(kv)= sin(alvp1*(kv-1))
   70 continue
      do 80 i=1,nu1
         factor(i) = one
         factor(i+nuv1/2) = one
   80 continue
      do 90 i=nu1+1,nuv1/2
         factor(i) = two
   90 continue
         eps(0) = one/two
      do 100 i=1,md+nd
         eps(i) = one
  100 continue

      end subroutine precal


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

    USE MR_KINDS

    USE MR_DEF_RANKS
    USE MR_DEF_FIELD_VARS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_UPDT_H

    REAL   (FDRD_KIND) , ALLOCATABLE , DIMENSION(:,:      ) :: ZBU , ZBV

    REAL   (FDRD_KIND) , ALLOCATABLE , DIMENSION(:,:      ) :: HSTOR
    REAL   (FDRD_KIND) , ALLOCATABLE , DIMENSION(:,:      ) :: HSTORU , HSTORV

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

  CONTAINS

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

    USE MR_MOD_FUNC_H

    USE MR_MOD_INTERP_XY

    IMPLICIT NONE

    INTEGER(IJID_KIND) :: I , J

    ALLOCATE(  HSTOR(1:NI1(NI,FDRD_KIND),1:NJ) ) ;  HSTOR = 0.0
      !BLOCK
        DO J = 1 , NJ
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI
             H( I , J ) = MR_FUNC_H(  HSTOR( I , J ) ,  ZS( I , J ) ,  ZB( I , J ) )
          END DO
        END DO
      !END BLOCK
    DEALLOCATE(  HSTOR )

    ALLOCATE( HSTORU(0:NI0(NI,FDRD_KIND),1:NJ) ) ; HSTORU = 0.0
      ALLOCATE( ZBU(0:NI0(NI,FDRD_KIND),1:NJ) )
        CALL MR_INTERP_XY_SS_U( NI , NJ , ZB , ZBU )
        DO J = 1 , NJ
         !DIR$ VECTOR ALIGNED
          DO I = 0 , NI
            HU( I , J ) = MR_FUNC_H( HSTORU( I , J ) , ZSU( I , J ) , ZBU( I , J ) )
          END DO
        END DO
      DEALLOCATE( ZBU )
    DEALLOCATE( HSTORU )

    ALLOCATE( HSTORV(1:NI1(NI,FDRD_KIND),0:NJ) ) ; HSTORV = 0.0
      ALLOCATE( ZBV(1:NI1(NI,FDRD_KIND),0:NJ) )
        CALL MR_INTERP_XY_SS_V( NI , NJ , ZB , ZBV )
        DO J = 0 , NJ
         !DIR$ VECTOR ALIGNED
          DO I = 1 , NI
            HV( I , J ) = MR_FUNC_H( HSTORV( I , J ) , ZSV( I , J ) , ZBV( I , J ) )
          END DO
        END DO
      DEALLOCATE( ZBV )
    DEALLOCATE( HSTORV )

  END SUBROUTINE MR_UPDT_H

  END MODULE MR_MOD_UPDT_H


      SUBROUTINE CHBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ,
     $                   WORK, INFO )
*
*  -- LAPACK routine (version 3.2) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO, VECT
      INTEGER            INFO, KD, LDAB, LDQ, N
*     ..
*     .. Array Arguments ..
      REAL               D( * ), E( * )
      COMPLEX            AB( LDAB, * ), Q( LDQ, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  CHBTRD reduces a complex Hermitian band matrix A to real symmetric
*  tridiagonal form T by a unitary similarity transformation:
*  Q**H * A * Q = T.
*
*  Arguments
*  =========
*
*  VECT    (input) CHARACTER*1
*          = 'N':  do not form Q;
*          = 'V':  form Q;
*          = 'U':  update a matrix X, by forming X*Q.
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  Upper triangle of A is stored;
*          = 'L':  Lower triangle of A is stored.
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  KD      (input) INTEGER
*          The number of superdiagonals of the matrix A if UPLO = 'U',
*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
*
*  AB      (input/output) COMPLEX array, dimension (LDAB,N)
*          On entry, the upper or lower triangle of the Hermitian band
*          matrix A, stored in the first KD+1 rows of the array.  The
*          j-th column of A is stored in the j-th column of the array AB
*          as follows:
*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
*          On exit, the diagonal elements of AB are overwritten by the
*          diagonal elements of the tridiagonal matrix T; if KD > 0, the
*          elements on the first superdiagonal (if UPLO = 'U') or the
*          first subdiagonal (if UPLO = 'L') are overwritten by the
*          off-diagonal elements of T; the rest of AB is overwritten by
*          values generated during the reduction.
*
*  LDAB    (input) INTEGER
*          The leading dimension of the array AB.  LDAB >= KD+1.
*
*  D       (output) REAL array, dimension (N)
*          The diagonal elements of the tridiagonal matrix T.
*
*  E       (output) REAL array, dimension (N-1)
*          The off-diagonal elements of the tridiagonal matrix T:
*          E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.
*
*  Q       (input/output) COMPLEX array, dimension (LDQ,N)
*          On entry, if VECT = 'U', then Q must contain an N-by-N
*          matrix X; if VECT = 'N' or 'V', then Q need not be set.
*
*          On exit:
*          if VECT = 'V', Q contains the N-by-N unitary matrix Q;
*          if VECT = 'U', Q contains the product X*Q;
*          if VECT = 'N', the array Q is not referenced.
*
*  LDQ     (input) INTEGER
*          The leading dimension of the array Q.
*          LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.
*
*  WORK    (workspace) COMPLEX array, dimension (N)
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  Further Details
*  ===============
*
*  Modified by Linda Kaufman, Bell Labs.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO
      PARAMETER          ( ZERO = 0.0E+0 )
      COMPLEX            CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            INITQ, UPPER, WANTQ
      INTEGER            I, I2, IBL, INCA, INCX, IQAEND, IQB, IQEND, J,
     $                   J1, J1END, J1INC, J2, JEND, JIN, JINC, K, KD1,
     $                   KDM1, KDN, L, LAST, LEND, NQ, NR, NRT
      REAL               ABST
      COMPLEX            T, TEMP
*     ..
*     .. External Subroutines ..
      EXTERNAL           CLACGV, CLAR2V, CLARGV, CLARTG, CLARTV, CLASET,
     $                   CROT, CSCAL, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, CONJG, MAX, MIN, REAL
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      INITQ = LSAME( VECT, 'V' )
      WANTQ = INITQ .OR. LSAME( VECT, 'U' )
      UPPER = LSAME( UPLO, 'U' )
      KD1 = KD + 1
      KDM1 = KD - 1
      INCX = LDAB - 1
      IQEND = 1
*
      INFO = 0
      IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( KD.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.KD1 ) THEN
         INFO = -6
      ELSE IF( LDQ.LT.MAX( 1, N ) .AND. WANTQ ) THEN
         INFO = -10
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CHBTRD', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Initialize Q to the unit matrix, if needed
*
      IF( INITQ )
     $   CALL CLASET( 'Full', N, N, CZERO, CONE, Q, LDQ )
*
*     Wherever possible, plane rotations are generated and applied in
*     vector operations of length NR over the index set J1:J2:KD1.
*
*     The real cosines and complex sines of the plane rotations are
*     stored in the arrays D and WORK.
*
      INCA = KD1*LDAB
      KDN = MIN( N-1, KD )
      IF( UPPER ) THEN
*
         IF( KD.GT.1 ) THEN
*
*           Reduce to complex Hermitian tridiagonal form, working with
*           the upper triangle
*
            NR = 0
            J1 = KDN + 2
            J2 = 1
*
            AB( KD1, 1 ) = REAL( AB( KD1, 1 ) )
            DO 90 I = 1, N - 2
*
*              Reduce i-th row of matrix to tridiagonal form
*
               DO 80 K = KDN + 1, 2, -1
                  J1 = J1 + KDN
                  J2 = J2 + KDN
*
                  IF( NR.GT.0 ) THEN
*
*                    generate plane rotations to annihilate nonzero
*                    elements which have been created outside the band
*
                     CALL CLARGV( NR, AB( 1, J1-1 ), INCA, WORK( J1 ),
     $                            KD1, D( J1 ), KD1 )
*
*                    apply rotations from the right
*
*
*                    Dependent on the the number of diagonals either
*                    CLARTV or CROT is used
*
                     IF( NR.GE.2*KD-1 ) THEN
                        DO 10 L = 1, KD - 1
                           CALL CLARTV( NR, AB( L+1, J1-1 ), INCA,
     $                                  AB( L, J1 ), INCA, D( J1 ),
     $                                  WORK( J1 ), KD1 )
   10                   CONTINUE
*
                     ELSE
                        JEND = J1 + ( NR-1 )*KD1
                        DO 20 JINC = J1, JEND, KD1
                           CALL CROT( KDM1, AB( 2, JINC-1 ), 1,
     $                                AB( 1, JINC ), 1, D( JINC ),
     $                                WORK( JINC ) )
   20                   CONTINUE
                     END IF
                  END IF
*
*
                  IF( K.GT.2 ) THEN
                     IF( K.LE.N-I+1 ) THEN
*
*                       generate plane rotation to annihilate a(i,i+k-1)
*                       within the band
*
                        CALL CLARTG( AB( KD-K+3, I+K-2 ),
     $                               AB( KD-K+2, I+K-1 ), D( I+K-1 ),
     $                               WORK( I+K-1 ), TEMP )
                        AB( KD-K+3, I+K-2 ) = TEMP
*
*                       apply rotation from the right
*
                        CALL CROT( K-3, AB( KD-K+4, I+K-2 ), 1,
     $                             AB( KD-K+3, I+K-1 ), 1, D( I+K-1 ),
     $                             WORK( I+K-1 ) )
                     END IF
                     NR = NR + 1
                     J1 = J1 - KDN - 1
                  END IF
*
*                 apply plane rotations from both sides to diagonal
*                 blocks
*
                  IF( NR.GT.0 )
     $               CALL CLAR2V( NR, AB( KD1, J1-1 ), AB( KD1, J1 ),
     $                            AB( KD, J1 ), INCA, D( J1 ),
     $                            WORK( J1 ), KD1 )
*
*                 apply plane rotations from the left
*
                  IF( NR.GT.0 ) THEN
                     CALL CLACGV( NR, WORK( J1 ), KD1 )
                     IF( 2*KD-1.LT.NR ) THEN
*
*                    Dependent on the the number of diagonals either
*                    CLARTV or CROT is used
*
                        DO 30 L = 1, KD - 1
                           IF( J2+L.GT.N ) THEN
                              NRT = NR - 1
                           ELSE
                              NRT = NR
                           END IF
                           IF( NRT.GT.0 )
     $                        CALL CLARTV( NRT, AB( KD-L, J1+L ), INCA,
     $                                     AB( KD-L+1, J1+L ), INCA,
     $                                     D( J1 ), WORK( J1 ), KD1 )
   30                   CONTINUE
                     ELSE
                        J1END = J1 + KD1*( NR-2 )
                        IF( J1END.GE.J1 ) THEN
                           DO 40 JIN = J1, J1END, KD1
                              CALL CROT( KD-1, AB( KD-1, JIN+1 ), INCX,
     $                                   AB( KD, JIN+1 ), INCX,
     $                                   D( JIN ), WORK( JIN ) )
   40                      CONTINUE
                        END IF
                        LEND = MIN( KDM1, N-J2 )
                        LAST = J1END + KD1
                        IF( LEND.GT.0 )
     $                     CALL CROT( LEND, AB( KD-1, LAST+1 ), INCX,
     $                                AB( KD, LAST+1 ), INCX, D( LAST ),
     $                                WORK( LAST ) )
                     END IF
                  END IF
*
                  IF( WANTQ ) THEN
*
*                    accumulate product of plane rotations in Q
*
                     IF( INITQ ) THEN
*
*                 take advantage of the fact that Q was
*                 initially the Identity matrix
*
                        IQEND = MAX( IQEND, J2 )
                        I2 = MAX( 0, K-3 )
                        IQAEND = 1 + I*KD
                        IF( K.EQ.2 )
     $                     IQAEND = IQAEND + KD
                        IQAEND = MIN( IQAEND, IQEND )
                        DO 50 J = J1, J2, KD1
                           IBL = I - I2 / KDM1
                           I2 = I2 + 1
                           IQB = MAX( 1, J-IBL )
                           NQ = 1 + IQAEND - IQB
                           IQAEND = MIN( IQAEND+KD, IQEND )
                           CALL CROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
     $                                1, D( J ), CONJG( WORK( J ) ) )
   50                   CONTINUE
                     ELSE
*
                        DO 60 J = J1, J2, KD1
                           CALL CROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
     $                                D( J ), CONJG( WORK( J ) ) )
   60                   CONTINUE
                     END IF
*
                  END IF
*
                  IF( J2+KDN.GT.N ) THEN
*
*                    adjust J2 to keep within the bounds of the matrix
*
                     NR = NR - 1
                     J2 = J2 - KDN - 1
                  END IF
*
                  DO 70 J = J1, J2, KD1
*
*                    create nonzero element a(j-1,j+kd) outside the band
*                    and store it in WORK
*
                     WORK( J+KD ) = WORK( J )*AB( 1, J+KD )
                     AB( 1, J+KD ) = D( J )*AB( 1, J+KD )
   70             CONTINUE
   80          CONTINUE
   90       CONTINUE
         END IF
*
         IF( KD.GT.0 ) THEN
*
*           make off-diagonal elements real and copy them to E
*
            DO 100 I = 1, N - 1
               T = AB( KD, I+1 )
               ABST = ABS( T )
               AB( KD, I+1 ) = ABST
               E( I ) = ABST
               IF( ABST.NE.ZERO ) THEN
                  T = T / ABST
               ELSE
                  T = CONE
               END IF
               IF( I.LT.N-1 )
     $            AB( KD, I+2 ) = AB( KD, I+2 )*T
               IF( WANTQ ) THEN
                  CALL CSCAL( N, CONJG( T ), Q( 1, I+1 ), 1 )
               END IF
  100       CONTINUE
         ELSE
*
*           set E to zero if original matrix was diagonal
*
            DO 110 I = 1, N - 1
               E( I ) = ZERO
  110       CONTINUE
         END IF
*
*        copy diagonal elements to D
*
         DO 120 I = 1, N
            D( I ) = AB( KD1, I )
  120    CONTINUE
*
      ELSE
*
         IF( KD.GT.1 ) THEN
*
*           Reduce to complex Hermitian tridiagonal form, working with
*           the lower triangle
*
            NR = 0
            J1 = KDN + 2
            J2 = 1
*
            AB( 1, 1 ) = REAL( AB( 1, 1 ) )
            DO 210 I = 1, N - 2
*
*              Reduce i-th column of matrix to tridiagonal form
*
               DO 200 K = KDN + 1, 2, -1
                  J1 = J1 + KDN
                  J2 = J2 + KDN
*
                  IF( NR.GT.0 ) THEN
*
*                    generate plane rotations to annihilate nonzero
*                    elements which have been created outside the band
*
                     CALL CLARGV( NR, AB( KD1, J1-KD1 ), INCA,
     $                            WORK( J1 ), KD1, D( J1 ), KD1 )
*
*                    apply plane rotations from one side
*
*
*                    Dependent on the the number of diagonals either
*                    CLARTV or CROT is used
*
                     IF( NR.GT.2*KD-1 ) THEN
                        DO 130 L = 1, KD - 1
                           CALL CLARTV( NR, AB( KD1-L, J1-KD1+L ), INCA,
     $                                  AB( KD1-L+1, J1-KD1+L ), INCA,
     $                                  D( J1 ), WORK( J1 ), KD1 )
  130                   CONTINUE
                     ELSE
                        JEND = J1 + KD1*( NR-1 )
                        DO 140 JINC = J1, JEND, KD1
                           CALL CROT( KDM1, AB( KD, JINC-KD ), INCX,
     $                                AB( KD1, JINC-KD ), INCX,
     $                                D( JINC ), WORK( JINC ) )
  140                   CONTINUE
                     END IF
*
                  END IF
*
                  IF( K.GT.2 ) THEN
                     IF( K.LE.N-I+1 ) THEN
*
*                       generate plane rotation to annihilate a(i+k-1,i)
*                       within the band
*
                        CALL CLARTG( AB( K-1, I ), AB( K, I ),
     $                               D( I+K-1 ), WORK( I+K-1 ), TEMP )
                        AB( K-1, I ) = TEMP
*
*                       apply rotation from the left
*
                        CALL CROT( K-3, AB( K-2, I+1 ), LDAB-1,
     $                             AB( K-1, I+1 ), LDAB-1, D( I+K-1 ),
     $                             WORK( I+K-1 ) )
                     END IF
                     NR = NR + 1
                     J1 = J1 - KDN - 1
                  END IF
*
*                 apply plane rotations from both sides to diagonal
*                 blocks
*
                  IF( NR.GT.0 )
     $               CALL CLAR2V( NR, AB( 1, J1-1 ), AB( 1, J1 ),
     $                            AB( 2, J1-1 ), INCA, D( J1 ),
     $                            WORK( J1 ), KD1 )
*
*                 apply plane rotations from the right
*
*
*                    Dependent on the the number of diagonals either
*                    CLARTV or CROT is used
*
                  IF( NR.GT.0 ) THEN
                     CALL CLACGV( NR, WORK( J1 ), KD1 )
                     IF( NR.GT.2*KD-1 ) THEN
                        DO 150 L = 1, KD - 1
                           IF( J2+L.GT.N ) THEN
                              NRT = NR - 1
                           ELSE
                              NRT = NR
                           END IF
                           IF( NRT.GT.0 )
     $                        CALL CLARTV( NRT, AB( L+2, J1-1 ), INCA,
     $                                     AB( L+1, J1 ), INCA, D( J1 ),
     $                                     WORK( J1 ), KD1 )
  150                   CONTINUE
                     ELSE
                        J1END = J1 + KD1*( NR-2 )
                        IF( J1END.GE.J1 ) THEN
                           DO 160 J1INC = J1, J1END, KD1
                              CALL CROT( KDM1, AB( 3, J1INC-1 ), 1,
     $                                   AB( 2, J1INC ), 1, D( J1INC ),
     $                                   WORK( J1INC ) )
  160                      CONTINUE
                        END IF
                        LEND = MIN( KDM1, N-J2 )
                        LAST = J1END + KD1
                        IF( LEND.GT.0 )
     $                     CALL CROT( LEND, AB( 3, LAST-1 ), 1,
     $                                AB( 2, LAST ), 1, D( LAST ),
     $                                WORK( LAST ) )
                     END IF
                  END IF
*
*
*
                  IF( WANTQ ) THEN
*
*                    accumulate product of plane rotations in Q
*
                     IF( INITQ ) THEN
*
*                 take advantage of the fact that Q was
*                 initially the Identity matrix
*
                        IQEND = MAX( IQEND, J2 )
                        I2 = MAX( 0, K-3 )
                        IQAEND = 1 + I*KD
                        IF( K.EQ.2 )
     $                     IQAEND = IQAEND + KD
                        IQAEND = MIN( IQAEND, IQEND )
                        DO 170 J = J1, J2, KD1
                           IBL = I - I2 / KDM1
                           I2 = I2 + 1
                           IQB = MAX( 1, J-IBL )
                           NQ = 1 + IQAEND - IQB
                           IQAEND = MIN( IQAEND+KD, IQEND )
                           CALL CROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
     $                                1, D( J ), WORK( J ) )
  170                   CONTINUE
                     ELSE
*
                        DO 180 J = J1, J2, KD1
                           CALL CROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
     $                                D( J ), WORK( J ) )
  180                   CONTINUE
                     END IF
                  END IF
*
                  IF( J2+KDN.GT.N ) THEN
*
*                    adjust J2 to keep within the bounds of the matrix
*
                     NR = NR - 1
                     J2 = J2 - KDN - 1
                  END IF
*
                  DO 190 J = J1, J2, KD1
*
*                    create nonzero element a(j+kd,j-1) outside the
*                    band and store it in WORK
*
                     WORK( J+KD ) = WORK( J )*AB( KD1, J )
                     AB( KD1, J ) = D( J )*AB( KD1, J )
  190             CONTINUE
  200          CONTINUE
  210       CONTINUE
         END IF
*
         IF( KD.GT.0 ) THEN
*
*           make off-diagonal elements real and copy them to E
*
            DO 220 I = 1, N - 1
               T = AB( 2, I )
               ABST = ABS( T )
               AB( 2, I ) = ABST
               E( I ) = ABST
               IF( ABST.NE.ZERO ) THEN
                  T = T / ABST
               ELSE
                  T = CONE
               END IF
               IF( I.LT.N-1 )
     $            AB( 2, I+1 ) = AB( 2, I+1 )*T
               IF( WANTQ ) THEN
                  CALL CSCAL( N, T, Q( 1, I+1 ), 1 )
               END IF
  220       CONTINUE
         ELSE
*
*           set E to zero if original matrix was diagonal
*
            DO 230 I = 1, N - 1
               E( I ) = ZERO
  230       CONTINUE
         END IF
*
*        copy diagonal elements to D
*
         DO 240 I = 1, N
            D( I ) = AB( 1, I )
  240    CONTINUE
      END IF
*
      RETURN
*
*     End of CHBTRD
*
      END


      SUBROUTINE poisson_sol_PHI(X,Y)
      USE global
      REAL*8 :: X(1,NXP4), Y(1,NXP4), TD(1,NX), PH0

      DO 66 IC=3, NXP2
         X(1,IC) = X(1,IC-1) - 0.5*DX*(Y(1,IC)+Y(1,IC))
         TD(1,IC-2) = X(1,IC)
   66 CONTINUE
      PH0 = SUM(TD)/NX
      X(1,:) = X(1,:)-PH0
      CALL boundary_condition(X(1,:))
      CALL FILTERn(X(1,:))
      END SUBROUTINE poisson_sol_PHI


      MODULE mat33_I
      INTERFACE
!...Generated by Pacific-Sierra Research 77to90  4.4G  09:18:42  03/09/06
      SUBROUTINE mat33 (A, B, C)
      USE vast_kind_param,ONLY: DOUBLE
      REAL(DOUBLE), DIMENSION(9), INTENT(IN) :: A
      REAL(DOUBLE), DIMENSION(9), INTENT(IN) :: B
      REAL(DOUBLE), DIMENSION(9), INTENT(OUT) :: C
      END SUBROUTINE
      END INTERFACE
      END MODULE


!************************************************************************
PROGRAM generate_coolrates

! Generate files containing tables of cooling and heating rates in
! the implicit cooling-module of RAMSES, to verify they are correct.
!------------------------------------------------------------------------
  use rt_icooling_module
  implicit none
  integer,parameter::nT=500,nXi=500
  real(dp),dimension(nT) :: a_T  ! Temperature array
  real(dp),dimension(nXi) :: a_X  ! Ionization array
  real(dp)::T0, T1, X0, X1, dlogT, dX
  real(dp),dimension(nT) :: a_Aa, a_Ab, a_B, a_dAadT, a_dAbdT, a_dBdT
  real(dp),dimension(nT,nXi) :: a_L, a_dLdT, a_dLdX
  integer::i, j, ilun_aa, ilun_ab, ilun_b, ilun_daadt, ilun_dabdt,      &
           ilun_dbdt,ncols
!------------------------------------------------------------------------

  T0=100 ; T1=1.d8
  dlogT = (log10(T1)-log10(T0))/(nT-1)
  do i = 0, nT-1
     a_T(i+1) = 10**(log10(T0) + dlogT * i)
  end do
  X0=0 ;  X1=1
  dX = (X1-X0)/(nXi-1)
  do i = 0, nX-1
     a_X(i+1) = X0 + dX * i
  end do

  do i = 1, nT
     a_Aa(i)    = comp_AlphaA(a_T(i))
     a_Ab(i)    = comp_AlphaB(a_T(i))
     a_B(i)     = comp_Beta(a_T(i))
     a_dAadT(i) = comp_dAlphaA_dT(a_T(i))
     a_dAbdT(i) = comp_dAlphaB_dT(a_T(i))
     a_dBdT(i)  = comp_dBeta_dT(a_T(i))
     do j = 1,nXi
        a_L(i,j)  = comp_coolrate(a_T(i), a_X(j), 1.d0, 1.d0, a_dLdT(i,j), a_dLdX(i,j))
     end do
  end do
  ilun_aa=21; ilun_ab=22; ilun_b=23; ilun_daadt=24; ilun_dabdt=24; ilun_dbdt=25
  open(ilun_aa,   file='alpha_a.list',    status='unknown')
  open(ilun_ab,   file='alpha_b.list',    status='unknown')
  open(ilun_b,    file='beta.list',       status='unknown')
  open(ilun_daadt,file='dalpha_a_dt.list',status='unknown')
  open(ilun_dabdt,file='dalpha_b_dt.list',status='unknown')
  open(ilun_dbdt, file='dbeta_dt.list',   status='unknown')

  write(ilun_aa,*) ''
  write(ilun_ab,*) ''
  write(ilun_b,*) ''
  write(ilun_daadt,*) ''
  write(ilun_dabdt,*) ''
  write(ilun_dbdt,*) ''

  write(ilun_aa,*) ''
  write(ilun_ab,*) ''
  write(ilun_b,*) ''
  write(ilun_daadt,*) ''
  write(ilun_dabdt,*) ''
  write(ilun_dbdt,*) ''

  ncols=2
  write(ilun_aa,*) ncols,nT
  write(ilun_ab,*) ncols,nT
  write(ilun_b,*) ncols,nT
  write(ilun_daadt,*) ncols,nT
  write(ilun_dabdt,*) ncols,nT
  write(ilun_dbdt,*) ncols,nT

  write(ilun_aa,*) ''
  write(ilun_ab,*) ''
  write(ilun_b,*) ''
  write(ilun_daadt,*) ''
  write(ilun_dabdt,*) ''
  write(ilun_dbdt,*) ''

  do i = 1,nT
     write(ilun_aa,   '(f21.6, d21.10)') a_T(i), a_Aa(i)
     write(ilun_ab,   '(f21.6, d21.10)') a_T(i), a_Ab(i)
     write(ilun_b,    '(f21.6, d21.10)') a_T(i), a_B(i)
     write(ilun_daadt,'(f21.6, d21.10)') a_T(i), a_dAadT(i)
     write(ilun_dabdt,'(f21.6, d21.10)') a_T(i), a_dAbdT(i)
     write(ilun_dbdt, '(f21.6, d21.10)') a_T(i), a_dBdt(i)
  end do

  close(ilun_aa)
  close(ilun_ab)
  close(ilun_b)
  close(ilun_daadt)
  close(ilun_dabdt)
  close(ilun_dbdt)

END PROGRAM generate_coolrates


      SUBROUTINE ZSYRK( UPLO, TRANS, N, K, ALPHA, A, LDA, BETA,
     $                  C, LDC )
*
*  -- Automatically Tuned Linear Algebra Software (ATLAS)
*     (C) Copyright 2000 All Rights Reserved
*
*  -- ATLAS routine -- F77 Interface -- Version 3.9.24 -- December 25, 2000
*
*  Author         : Antoine P. Petitet
*  Originally developed at the University of Tennessee,
*  Innovative Computing Laboratory,  Knoxville TN, 37996-1301, USA.
*
*  ---------------------------------------------------------------------
*
*  -- Copyright notice and Licensing terms:
*
*  Redistribution  and  use in  source and binary forms, with or without
*  modification, are  permitted provided  that the following  conditions
*  are met:
*
*  1. Redistributions  of  source  code  must retain the above copyright
*     notice, this list of conditions and the following disclaimer.
*  2. Redistributions in binary form must reproduce  the above copyright
*     notice,  this list of conditions, and the  following disclaimer in
*     the documentation and/or other materials provided with the distri-
*     bution.
*  3. The name of the University,  the ATLAS group,  or the names of its
*     contributors  may not be used to endorse or promote products deri-
*     ved from this software without specific written permission.
*
*  -- Disclaimer:
*
*  THIS  SOFTWARE  IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
*  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,  INCLUDING,  BUT NOT
*  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
*  A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY
*  OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,  INDIRECT, INCIDENTAL, SPE-
*  CIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
*  TO,  PROCUREMENT  OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
*  OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEO-
*  RY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT  (IN-
*  CLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
*  THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*  ---------------------------------------------------------------------
*
*     .. Scalar Arguments ..
      CHARACTER*1        UPLO, TRANS
      INTEGER            N, K, LDA, LDC
      COMPLEX*16         ALPHA, BETA
*     ..
*     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), C( LDC, * )
*     ..
*
*  Purpose
*  =======
*
*  ZSYRK  performs one of the symmetric rank k operations
*
*     C := alpha * A * A' + beta * C,
*
*  or
*
*     C := alpha * A' * A + beta * C,
*
*  where alpha and beta are scalars, C is an n by n symmetric matrix and
*  A is an  n by k  matrix in the first case and a  k by n matrix in the
*  second case.
*
*  Arguments
*  =========
*
*  UPLO    (input)                       CHARACTER*1
*          On entry, UPLO  specifies whether the upper or lower triangu-
*          lar part of the array C is to be referenced as follows:
*
*              UPLO = 'U' or 'u'   Only the upper triangular part of C
*                                  is to be referenced.
*
*              UPLO = 'L' or 'l'   Only the lower triangular part of C
*                                  is to be referenced.
*
*          Unchanged on exit.
*
*  TRANS   (input)                       CHARACTER*1
*          On entry,  TRANS  specifies the  operation to be performed as
*          follows:
*
*             TRANS = 'N' or 'n'  C := alpha * A * A' + beta * C,
*
*             TRANS = 'T' or 't'  C := alpha * A' * A + beta * C.
*
*          Unchanged on exit.
*
*  N       (input)                       INTEGER
*          On entry, N specifies the order of the matrix C. N must be at
*          least zero. Unchanged on exit.
*
*  K       (input)                       INTEGER
*          On entry, with TRANS = 'N' or 'n',  K specifies the number of
*          columns of the matrix A, and with TRANS = 'T' or 't', K  spe-
*          cifies  the  number of rows of the  matrix  A.  K  must be at
*          least zero. Unchanged on exit.
*
*  ALPHA   (input)                       COMPLEX*16
*          On entry, ALPHA specifies the scalar alpha.   When  ALPHA  is
*          supplied as zero  then  the  entries of the matrix A need not
*          be set on input. Unchanged on exit.
*
*  A       (input)                       COMPLEX*16 array
*          On entry, A is an array of DIMENSION ( LDA, ka ), where ka is
*          k  when  TRANS = 'N' or 'n', and is n otherwise. Before entry
*          with TRANS = 'N' or 'n', the leading n by k part of the array
*          A must contain the matrix A,  otherwise  the  leading  k by n
*          part of the array A must contain the matrix A.  Unchanged  on
*          exit.
*
*  LDA     (input)                       INTEGER
*          On entry, LDA  specifies the first dimension of A as declared
*          in  the   calling  (sub)  program.   When  TRANS = 'N' or 'n'
*          then  LDA  must be at least  max( 1, n ), otherwise  LDA must
*          be at least  max( 1, k ). Unchanged on exit.
*
*  BETA    (input)                       COMPLEX*16
*          On entry,  BETA  specifies the scalar  beta.   When  BETA  is
*          supplied as zero  then  the  entries of the matrix C need not
*          be set on input. Unchanged on exit.
*
*  C       (input/output)                COMPLEX*16 array
*          On entry, C is an array of DIMENSION ( LDC, n ). Before entry
*          with  UPLO = 'U' or 'u',  the leading n by n upper triangular
*          part of the array C must contain the upper triangular part of
*          the  symmetric matrix  and the strictly lower triangular part
*          of C is not referenced. On exit, the upper triangular part of
*          the array  C  is  overwritten by the upper triangular part of
*          the updated matrix. Before entry with  UPLO = 'L' or 'l', the
*          leading n by n lower triangular part of the array C must con-
*          tain the lower triangular part of the  symmetric  matrix  and
*          the strictly upper triangular part of C is not referenced. On
*          exit, the lower triangular part of the array C is overwritten
*          by the lower triangular part of the updated matrix.
*
*  LDC     (input)                       INTEGER
*          On entry,  LDC specifies the first dimension of C as declared
*          in   the  calling  (sub)  program.   LDC  must  be  at  least
*          max( 1, n ). Unchanged on exit.
*
*  Further Details
*  ===============
*
*  For further information on the Level 1 BLAS specification, see:
*
*  ``A Proposal for Standard Linear Algebra Subprograms''  by R. Hanson,
*  F. Krogh and C. Lawson, ACM SIGNUM Newsl., 8(16), 1973,
*
*  ``Basic Linear Algebra Subprograms for Fortran Usage''  by C. Lawson,
*  R. Hanson, D. Kincaid and F. Krogh,  ACM Transactions on Mathematical
*  Software, 5(3) pp 308-323, 1979.
*
*  For further information on the Level 2 BLAS specification, see:
*
*  ``An  Extended Set of  FORTRAN  Basic Linear Algebra Subprograms'' by
*  J. Dongarra,  J. Du Croz,  S. Hammarling and R. Hanson,  ACM Transac-
*  tions on Mathematical Software, 14(1) pp 1-17, 1988.
*
*  ``Algorithm 656: An extended Set of Basic Linear Algebra Subprograms:
*  Model Implementation and Test Programs''  by J. Dongarra, J. Du Croz,
*  S. Hammarling and R. Hanson,  ACM  Transactions on Mathematical Soft-
*  ware, 14(1) pp 18-32, 1988.
*
*  For further information on the Level 3 BLAS specification, see:
*
*  ``A Set of Level 3 Basic Linear Algebra Subprograms'' by J. Dongarra,
*  J. Du Croz, I. Duff and S. Hammarling, ACM Transactions on Mathemati-
*  cal Software, 16(1), pp 1-17, 1990.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            ILOWER, IUPPER
      PARAMETER          ( IUPPER = 121, ILOWER = 122 )
      INTEGER            ICOTRAN, INOTRAN, ITRAN
      PARAMETER          ( INOTRAN = 111, ITRAN = 112, ICOTRAN = 113 )
*     ..
*     .. Local Scalars ..
      INTEGER            INFO, ITRANS, IUPLO, NROWA
*     ..
*     .. External Subroutines ..
      EXTERNAL           ATL_F77WRAP_ZSYRK, XERBLA
*     ..
*     .. External Functions ..
      EXTERNAL           LSAME
      LOGICAL            LSAME
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
      INFO = 0
*
      IF(      LSAME( UPLO , 'L' ) ) THEN
         IUPLO = ILOWER
      ELSE IF( LSAME( UPLO , 'U' ) ) THEN
         IUPLO = IUPPER
      ELSE
         IUPLO = ILOWER
         INFO  = 1
      END IF
*
      IF(      LSAME( TRANS, 'N' ) ) THEN
         ITRANS = INOTRAN
         NROWA  = N
      ELSE IF( LSAME( TRANS, 'T' ) ) THEN
         ITRANS = ITRAN
         NROWA  = K
      ELSE IF( INFO.EQ.0 ) THEN
         ITRANS = INOTRAN
         NROWA  = 0
         INFO   = 2
      END IF
*
      IF( INFO.EQ.0 ) THEN
         IF(      N  .LT.0               ) THEN
            INFO = 3
         ELSE IF( K  .LT.0               ) THEN
            INFO = 4
         ELSE IF( LDA.LT.MAX( 1, NROWA ) ) THEN
            INFO = 7
         ELSE IF( LDC.LT.MAX( 1, N     ) ) THEN
            INFO = 10
         END IF
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZSYRK ', INFO )
         RETURN
      END IF
*
      CALL ATL_F77WRAP_ZSYRK( IUPLO, ITRANS, N, K, ALPHA, A, LDA,
     $                        BETA, C, LDC )
*
      RETURN
*
*     End of ZSYRK
*
      END


      SUBROUTINE histat(OHIST,NPTS,mean,sigma,maxfreq)
C   Compute mean and standard deviation (for byte inputs only).
C
      INTEGER*4 OHIST(0:255)
      REAL*4 MEAN,SIGMA
      REAL*8 DMEAN,DSIGMA

      DMEAN = 0.0D0		!Mean DN of input image
      DSIGMA = 0.0D0		!Standard deviation of input image
      MAXFREQ = 0

      IF (NPTS.EQ.0) THEN	!Test number of pixels against 0
	MEAN = DMEAN            !Set mean, std. dev. & max. freq.
	SIGMA = DSIGMA		!to 0; then exit routine.
        GOTO 15
      ENDIF

      DO 10 J=0,255
      NPIXELS = OHIST(J)
      IF (NPIXELS.EQ.0) GOTO 10
      DN = J
      DMEAN = DMEAN + NPIXELS*DN
      DSIGMA = DSIGMA + NPIXELS*DN**2
      IF (J.NE.0.AND.J.NE.255.AND.NPIXELS.GT.MAXFREQ) MAXFREQ=NPIXELS
   10 CONTINUE

      DMEAN = DMEAN/NPTS
      MEAN = DMEAN
      SIGMA = DSQRT(DSIGMA/NPTS-DMEAN*DMEAN)
   15 RETURN
      END
C
C   Compute mean and standard deviation (for halfword inputs only).
C
      SUBROUTINE histat2(HIST,NPTS,mean,sigma,mindn,maxdn,maxfreq)
      INTEGER*4 HIST(-32768:32767)
      REAL*4 MEAN,SIGMA
      REAL*8 DMEAN,DSIGMA

      DN = 0.0			!DN value
      DMEAN = 0.0D0		!Mean DN of input image
      DSIGMA = 0.0D0		!Standard deviation of input image
      MINDN = 32767
      MAXFREQ = 0

      IF (NPTS.EQ.0) THEN	!Test number of pixels against 0
	MEAN = DMEAN		!Set mean, std. dev. & max. freq.
	SIGMA = DSIGMA		!to 0; set max. and min. DN to
	MAXDN = MINDN		!32767; then exit program.
        GOTO 15
      ENDIF

      DO 10 J=-32768,32767
      NPIXELS = HIST(J)
      IF (NPIXELS.EQ.0) GOTO 10
      DN = J
      DMEAN = DMEAN + NPIXELS*DN
      DSIGMA = DSIGMA + NPIXELS*DN**2
      IF (J.LT.MINDN) MINDN=J
      IF (J.NE.-32768.AND.J.NE.32767.AND.NPIXELS.GT.MAXFREQ)
     &		 MAXFREQ=NPIXELS
   10 CONTINUE

      MAXDN = DN + 0.5
      DMEAN = DMEAN/NPTS
      MEAN = DMEAN
      SIGMA = DSQRT(DSIGMA/NPTS-DMEAN*DMEAN)
   15 RETURN
      END


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

module gau_param

! Update vector with a Gaussian noise.
! x(i) *= (1. + G * gaussian)

use random_seq_mod, only : random_seq_type, init_random_seq, random_gaussian

implicit none

integer, parameter   :: r8 = selected_real_kind(14,30)

integer,  parameter  :: model_size = 1
real(r8), parameter  :: G          = 0.005_r8
real(r8), parameter  :: deltat     = 0.01_r8
real(r8)             :: x(model_size)
character (len = 128):: file_in      = 'model.in'
character (len = 128):: file_out      = 'model.out'
integer              :: i, ts, td, errval
type(random_seq_type), save :: sr

integer, parameter   :: nr = 100

contains
!===================================================================

subroutine read_state( )

integer :: size, i, errval

open(11,file=trim(file_in),status='old',iostat=errval)
if ( errval .eq. 0 ) then
   read(11,*)
   read(11,*)ts, td
   do i = 1, model_size
     read(11,*) x(i)
   enddo
   close(11)
else
   ts = 0
   td = 0
   x = -77.6_r8
endif

end subroutine read_state

subroutine march_ahead()

integer :: i, getpid, tempr

tempr = mod(getpid(),54000)
call init_random_seq(sr, tempr)
do i = 1, model_size
   ! Advance the parameter with a Gaussian noise
   x(i) = x(i)*(1._r8 + G * random_gaussian(sr, 0.0_r8, 1.0_r8))
end do

end  subroutine march_ahead

subroutine model_output()

open(11,file=trim(file_out),status='unknown',iostat=errval)
write(11,*)ts, td
do i = 1, model_size
   write(11,*) x(i)
enddo
close(11)
end subroutine model_output

end module gau_param

program gau_param_main
use gau_param
implicit none

call read_state( )
call march_ahead( )
call model_output( )

end program gau_param_main

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


!=======================================================================
!
!  Check for convergence in the relative abundances of all species
!  of each particle. Set the relevant convergence flags. Calculate
!  the percentage of particles that have converged.
!
!-----------------------------------------------------------------------
SUBROUTINE CHECK_CHEMISTRY_CONVERGENCE(NPART,NSPEC,PARTICLE,PERCENTAGE_CONVERGED)

   USE HEALPIX_TYPES
   USE PARTICLE_MODULE
   USE MAIN_MODULE, ONLY : ABUNDANCE_LIMIT,CHEMISTRY_CONVERGENCE_CRITERION

   IMPLICIT NONE

   INTEGER(KIND=I4B),   INTENT(IN)    :: NPART,NSPEC
   TYPE(PARTICLE_TYPE), INTENT(INOUT) :: PARTICLE(:)
   REAL(KIND=DP),       INTENT(OUT)   :: PERCENTAGE_CONVERGED

   INTEGER(KIND=I4B) :: I,P
   REAL(KIND=DP) :: RELATIVE_CHANGE

   PARTICLE%CHEMISTRY_CONVERGED=.TRUE.
   DO P=1,NPART ! Loop over particles
      DO I=1,NSPEC ! Loop over species

!        Skip this species if its abundance is below the cut-off
         IF(PARTICLE(P)%ABUNDANCE(I).LT.ABUNDANCE_LIMIT) CYCLE

!        Skip this species if its abundance has not changed
         IF(PARTICLE(P)%ABUNDANCE(I).EQ.PARTICLE(P)%PREVIOUS_ABUNDANCE(I)) CYCLE

!        Calculate the relative change in abundance between this iteration and the previous
         RELATIVE_CHANGE=ABS(PARTICLE(P)%ABUNDANCE(I)-PARTICLE(P)%PREVIOUS_ABUNDANCE(I)) &
                       & *2/(PARTICLE(P)%ABUNDANCE(I)+PARTICLE(P)%PREVIOUS_ABUNDANCE(I))

!        If the relative change is greater than the criterion for convergence, set the flag to false
         IF(RELATIVE_CHANGE.GT.CHEMISTRY_CONVERGENCE_CRITERION) THEN
            PARTICLE(P)%CHEMISTRY_CONVERGED=.FALSE.
            EXIT
         END IF

      END DO ! End of loop over species
   END DO ! End of loop over particles

!  Calculate the percentage of particles whose abundances have converged
   PERCENTAGE_CONVERGED=COUNT(PARTICLE%CHEMISTRY_CONVERGED)/REAL(NPART,KIND=DP)*100

   RETURN
END SUBROUTINE CHECK_CHEMISTRY_CONVERGENCE
!=======================================================================


      subroutine f_main
!  ********************************************************************
!  ********************************************************************
      use mpmodule
      use avh_olo_forIREGI
      implicit none
      integer :: nn
      character(4) :: next
      real(kind(1d0)) :: mu
!
!      call olo_onshell( 1d-6 )
!      call olo_unit( 6 ,'printall' )
      call mpinit(34)
      call olo_precision(34)
      call olo_setting
!
      next = 'next'
      do while (next.eq.'next')
        read(5,*) nn ,mu
        call olo_scale( mu )
        if     (nn.eq.2) then
          call test_2
        elseif (nn.eq.3) then
          call test_3
        else!if(nn.eq.4) then
          call test_4
        endif
        read(5,*) next
      enddo
      end subroutine

      subroutine test_4
!  ********************************************************************
!  ********************************************************************
      use mpmodule
      use avh_olo_forIREGI
      implicit none
      complex(kind(1d0)) :: p1,p2,p3,p4,p12,p23,m1,m2,m3,m4,zdp(0:2)
      type(mp_complex) :: p1_mp,p2_mp,p3_mp,p4_mp,p12_mp,p23_mp
      type(mp_complex) :: m1_mp,m2_mp,m3_mp,m4_mp,zmp(0:2)
!
      read(5,*) p1
      read(5,*) p2
      read(5,*) p3
      read(5,*) p4
      read(5,*) p12
      read(5,*) p23
      read(5,*) m1
      read(5,*) m2
      read(5,*) m3
      read(5,*) m4
      write(6,101) 'p1 : (',real(p1),',',aimag(p1),')'
      write(6,101) 'p2 : (',real(p2),',',aimag(p2),')'
      write(6,101) 'p3 : (',real(p3),',',aimag(p3),')'
      write(6,101) 'p4 : (',real(p4),',',aimag(p4),')'
      write(6,101) 'p12: (',real(p12),',',aimag(p12),')'
      write(6,101) 'p23: (',real(p23),',',aimag(p23),')'
      write(6,101) 'm1 : (',real(m1),',',aimag(m1),')'
      write(6,101) 'm2 : (',real(m2),',',aimag(m2),')'
      write(6,101) 'm3 : (',real(m3),',',aimag(m3),')'
      write(6,101) 'm4 : (',real(m4),',',aimag(m4),')'
  101 format(a6,d31.24,a1,d31.24,a1)
!
      p1_mp =p1
      p2_mp =p2
      p3_mp =p3
      p4_mp =p4
      p12_mp=p12
      p23_mp=p23
      m1_mp =m1
      m2_mp =m2
      m3_mp =m3
      m4_mp =m4
      call olo( zdp ,p1,p2,p3,p4,p12,p23  ,m1,m2,m3,m4 )
      call olo( zmp ,p1_mp,p2_mp,p3_mp,p4_mp,p12_mp,p23_mp &
                    ,m1_mp,m2_mp,m3_mp,m4_mp )
!
      write(6,'(a10)') ' eps^( 0):'
      write(6,'(a8,2d24.16)') '    olo:',zdp(0)
      call mpwrite(6,zmp(0))
      write(6,'(a10)') ' eps^(-1):'
      write(6,'(a8,2d24.16)') '    olo:',zdp(1)
      call mpwrite(6,zmp(1))
      write(6,'(a10)') ' eps^(-2):'
      write(6,'(a8,2d24.16)') '    olo:',zdp(2)
      call mpwrite(6,zmp(2))
      write(6,*)
!
      end subroutine

      subroutine test_3
!  ********************************************************************
!  ********************************************************************
      use mpmodule
      use avh_olo_forIREGI
      implicit none
      complex(kind(1d0)) :: p1,p2,p3,m1,m2,m3,zdp(0:2)
      type(mp_complex) :: p1_mp,p2_mp,p3_mp
      type(mp_complex) :: m1_mp,m2_mp,m3_mp,zmp(0:2)
!
      read(5,*) p1
      read(5,*) p2
      read(5,*) p3
      read(5,*) m1
      read(5,*) m2
      read(5,*) m3
      write(6,101) 'p1 : (',real(p1),',',aimag(p1),')'
      write(6,101) 'p2 : (',real(p2),',',aimag(p2),')'
      write(6,101) 'p3 : (',real(p3),',',aimag(p3),')'
      write(6,101) 'm1 : (',real(m1),',',aimag(m1),')'
      write(6,101) 'm2 : (',real(m2),',',aimag(m2),')'
      write(6,101) 'm3 : (',real(m3),',',aimag(m3),')'
  101 format(a6,d31.24,a1,d31.24,a1)
!
      p1_mp=p1
      p2_mp=p2
      p3_mp=p3
      m1_mp=m1
      m2_mp=m2
      m3_mp=m3
      call olo( zdp ,p1,p2,p3 ,m1,m2,m3 )
      call olo( zmp ,p1_mp,p2_mp,p3_mp ,m1_mp,m2_mp,m3_mp )
!
      write(6,'(a10)') ' eps^( 0):'
      write(6,'(a8,2d24.16)') '    olo:',zdp(0)
      call mpwrite(6,zmp(0))
      write(6,'(a10)') ' eps^(-1):'
      write(6,'(a8,2d24.16)') '    olo:',zdp(1)
      call mpwrite(6,zmp(1))
      write(6,'(a10)') ' eps^(-2):'
      write(6,'(a8,2d24.16)') '    olo:',zdp(2)
      call mpwrite(6,zmp(2))
      write(6,*)
!
      end subroutine

      subroutine test_2
!  ********************************************************************
!  ********************************************************************
      use mpmodule
      use avh_olo_forIREGI
      implicit none
      complex(kind(1d0)) :: p1,m1,m2,zdp(0:2)
      type(mp_complex) :: m1_mp,m2_mp,p1_mp,zmp(0:2)
!
      read(5,*) p1
      read(5,*) m1
      read(5,*) m2
      write(6,101) 'p1 : (',real(p1),',',aimag(p1),')'
      write(6,101) 'm1 : (',real(m1),',',aimag(m1),')'
      write(6,101) 'm2 : (',real(m2),',',aimag(m2),')'
  101 format(a6,d31.24,a1,d31.24,a1)
!
      p1_mp = p1
      m1_mp = m1
      m2_mp = m2
      call olo( zdp ,p1 ,m1,m2 )
      call olo( zmp ,p1_mp ,m1_mp,m2_mp )
!
      write(6,'(a10)') ' eps^( 0):'
      write(6,'(a8,2d24.16)') '    olo:',zdp(0)
      call mpwrite(6,zmp(0))
      write(6,'(a10)') ' eps^(-1):'
      write(6,'(a8,2d24.16)') '    olo:',zdp(1)
      call mpwrite(6,zmp(1))
      write(6,'(a10)') ' eps^(-2):'
      write(6,'(a8,2d24.16)') '    olo:',zdp(2)
      call mpwrite(6,zmp(2))
      write(6,*)
!
      end subroutine


C=======================================================================

      Subroutine SHOCK(NX,PYOUT)
C-----------------------------------------------------------------------
c
c     PROGRESSING 1D GASDYNAMIC SHOCK - LCPFCT Test # 2      August 1992
c
c     This program runs a simple 1D gasdynamic shock through a uniform
c     grid using LCPFCT and its utility routines. The fluid is ideal and
c     inviscid with constant GAMMA0 = 1.4.  The boundary conditions are
c     specified external values on both ends of the system.
c
C-----------------------------------------------------------------------

         Implicit NONE

         Logical,parameter ::doplot=.false.
         Integer   ALPHA, BC1, BCN,   MAXSTP, IPRINT
         Integer, Intent(IN) ::   NX
         Integer,Parameter :: NPT = 202
         Real, Intent(OUT)   ::   PYOUT(NPT*NX,6)

         Integer   NXP,    MX, ISTEP,  JSTEP, I,   LOUT
         Real      MACH,       V0,         DELTAX,     DELTAT
         Real      RHOSUM,     RHVSUM,     PRESUM,     ERGSUM
         Real      VNEW(NPT),  PNEW(NPT),  TNEW(NPT),  XINT(NPT)
         Real      CSAMB,      ERG_IN,     ERGAMB,     RELAX
         Real      TIME

         Real      RHO_IN,     PRE_IN,     VEL_IN,     GAMMA0
         Real      RHOAMB,     PREAMB,     VELAMB,     GAMMAM
         Real      RHON(NPT),  RVXN(NPT),  RVTN(NPT),  ERGN(NPT)
         Common    / ARRAYS / RHON,   RVXN,   RVTN,   ERGN,   RELAX,
     &                        RHO_IN, PRE_IN, VEL_IN, GAMMA0,
     &                        RHOAMB, PREAMB, VELAMB, GAMMAM

 1000 Format ( '1    LCPFCT Test # 2 - Progressing Shock:',
     &         '   Step =', I4, '   NX =', I3, '   DT =', F6.3 )
 1001 Format (2X, I3, 1P6E13.5)
 1002 Format ('    I    Density  Temperature   Pressure  ',
     &    '  Velocity     Energy    Interfaces')
 1003 Format ('0 Conservation Sums ', /, 5X, 1PE12.4, 12X, 3E12.4, /)

c  The Progressing Shock test run control parameters are specified here.
c  (change for other cases) . . .
C-----------------------------------------------------------------------
      MACH   = 5.0  ! Mach number of the incoming ambient flow
      V0     = 3.0  ! Shock speed in the lab frame
      DELTAX = 1.0  ! Cell size
      DELTAT = 0.05 ! Timestep for the calculation
      ALPHA  = 1    ! (1 = Cartesian, 2 = Cylindrical, 3 = Spherical)
      LOUT   =  11  ! Logical unit number of printed output device
      MX     =  10  ! Number of cells initialized behind the shock
      MAXSTP = 201  ! Maximum number of timesteps of length DELTAT
      IPRINT =  25  ! Frequency of intermediate result printouts

c  Initialize the variables in Common for use in GASDYN . . .
C-----------------------------------------------------------------------
      GAMMA0 = 1.4  ! Gas constant
      PREAMB = 1.0  ! Ambient (unshocked) pressure on the right
      RHOAMB = 1.0  ! Density of the unshocked fluid on the right
      RELAX  = 0.0  ! Relaxation rate, not used when BC1, BCN = 2
      GAMMAM = GAMMA0 - 1.0

c  The Rankine-Hugoniot conditions are set for boundaries . . .
C-----------------------------------------------------------------------
      CSAMB  = SQRT (GAMMA0*PREAMB/RHOAMB)
      VELAMB = -MACH*CSAMB
      VEL_IN = VELAMB*(GAMMAM + 2.0/MACH**2)/(GAMMA0 + 1.0)
      RHO_IN = RHOAMB*VELAMB/VEL_IN
      PRE_IN = PREAMB - RHO_IN*VEL_IN**2 + RHOAMB*VELAMB**2
      VELAMB = VELAMB + V0
      VEL_IN = VEL_IN + V0
      ERGAMB = PREAMB/(GAMMA0 - 1.0) + 0.5*RHOAMB*VELAMB**2
      ERG_IN = PRE_IN/(GAMMA0 - 1.0) + 0.5*RHO_IN*VEL_IN**2

c  Define the cell interface locations and physical variables . . .
C-----------------------------------------------------------------------
      NXP = NX + 1
      Do I = 1, NXP
          XINT(I) = FLOAT(I-1)*DELTAX
      End Do
      Do I = MX+1, NX
         RHON(I) = RHOAMB
         RVXN(I) = RHOAMB*VELAMB
         RVTN(I) = 0.0
         ERGN(I) = ERGAMB
      End Do
      Do I = 1, MX
         RHON(I) = RHO_IN
         RVXN(I) = RHO_IN*VEL_IN
         RVTN(I) = 0.0
         ERGN(I) = ERG_IN
      End Do
c one time write of column headers
      If (doplot) Then
          Write (  LOUT, 1002 )
      End if
c  Begin loop over timesteps . . .
C-----------------------------------------------------------------------
      BC1 = 4
      BCN = 4
      Call RESIDIFF ( 1.000 )
      Call MAKEGRID ( XINT, XINT, 1, NXP, ALPHA )

      Do ISTEP = 1, MAXSTP

c  The results are printed when required . . .
C-----------------------------------------------------------------------
c         If ( MOD(ISTEP-1, IPRINT) .eq. 0) Then

            JSTEP = ISTEP - 1
            Do I = 1, NX
               VNEW(I) = RVXN(I)/RHON(I)
               PNEW(I) = GAMMAM*(ERGN(I) - 0.5*RVXN(I)*VNEW(I))
               TNEW(I) = PNEW(I)/RHON(I)
            End do

            Call CONSERVE (RHON, 1, NX, RHOSUM)
            Call CONSERVE (PNEW, 1, NX, PRESUM)
            Call CONSERVE (RVXN, 1, NX, RHVSUM)
            Call CONSERVE (ERGN, 1, NX, ERGSUM)
            PRESUM = PRESUM/GAMMAM
           If (doplot) Then
            Write ( LOUT, 1000 ) JSTEP, NX, DELTAT
            Write (  LOUT, 1001 ) ( I, RHON(I), TNEW(I), PNEW(I),
     &           VNEW(I), ERGN(I), XINT(I), I = 1, NX )
            Write (  LOUT, 1003 ) RHOSUM, PRESUM, RHVSUM, ERGSUM
           End If
c         End If

c  The FCT integration of the continuity equations is performed . . .
C-----------------------------------------------------------------------
         Call GASDYN ( 1, NX, BC1, BCN, DELTAT )
         TIME = TIME + DELTAT
c let's pass an array out to Python!
         PYOUT((NX*(ISTEP-1)+1):(NX*ISTEP),1) = RHON(1:NX)
         PYOUT((NX*(ISTEP-1)+1):(NX*ISTEP),2) = TNEW(1:NX)
         PYOUT((NX*(ISTEP-1)+1):(NX*ISTEP),3) = PNEW(1:NX)
         PYOUT((NX*(ISTEP-1)+1):(NX*ISTEP),4) = VNEW(1:NX)
         PYOUT((NX*(ISTEP-1)+1):(NX*ISTEP),5) = ERGN(1:NX)
         PYOUT((NX*(ISTEP-1)+1):(NX*ISTEP),6) = XINT(1:NX)
      End do

      End Subroutine SHOCK


      module eqn_state_m
c
c----------------------------------------
c    aims to compute the equation of
c    state
c----------------------------------------
        use e3_param_m
        use number_def_m
        use matdat_def_m
        use mmatpar_m
        use dgifinp_m
c
        implicit none
c
        real*8 :: rho_ref, p_ref, T_ref, alpha_P, beta_T, cv_liq
        real*8 :: rho_ref_s, p_ref_s, T_ref_s, alpha_P_s, cv_s
        real*8 :: bulkMod_s, shearMod_s
c
      contains
c
      subroutine getthm6_ideal_gas
c
        mw    = mat_prop(mater,iprop_ideal_gas_mw, 1)
        gamma = mat_prop(mater,iprop_ideal_gas_gamma,1)
        Rgas  = Ru/mw*1.0d3
        gamma1 = gamma - one
c
        rho = pres / (Rgas*T)
        ei  = T * Rgas / gamma1
c
      end subroutine getthm6_ideal_gas
c
      subroutine getthm7_ideal_gas
c
        call getthm6_ideal_gas
c
        h   = T * Rgas / gamma1 * gamma
        cp  = Rgas*gamma / gamma1
        alphaP = one / T
        betaT  = one / pres
        if (associated(cv)) cv  = Rgas / gamma1
        if (associated(gamb)) gamb = gamma1
        if (associated(c)) c =  sqrt( gamma * Rgas * T )
c
      end subroutine getthm7_ideal_gas
c
      subroutine getthm6_ideal_gas_mixture
c
        integer :: iel
        real*8, dimension(npro) :: mw,rgas,y
c
        y = vap_frac
        y = max(zero,y)
        y = min(one, y)
c
        mw  = y*MW_liquid + (one-y)*mat_prop(mater,iprop_ideal_gas_mw, 1)
c
        gamma = mat_prop(mater,iprop_ideal_gas_gamma,1)
        Rgas  = Ru/mw*1.0d3
        gamma1 = gamma - one
c
        rho = pres / (Rgas*T)
        ei  = T * Rgas / gamma1
c
      end subroutine getthm6_ideal_gas_mixture
c
      subroutine getthm7_ideal_gas_mixture
c
        real*8, dimension(npro) :: mw,rgas,y,gamma_mix,cp_gas,cv_gas,cv_mix,cp_mix
c
        y = vap_frac
        y = max(zero,y)
        y = min(one, y)
c
        mw  = y*MW_liquid + (one-y)*mat_prop(mater,iprop_ideal_gas_mw, 1)
c
        gamma = mat_prop(mater,iprop_ideal_gas_gamma,1)
        gamma1 = gamma - one
        Rgas  = Ru/mw*1.0d3
        rho = pres / (Rgas*T)
        cp_gas  = Rgas*gamma / gamma1
        cv_gas  = Rgas / gamma1
        cv_liq  = mat_prop(2,iprop_liquid_1_cv,     1)
c
        cp_mix = y*cv_liq + (one-y)*cp_gas
        cv_mix = y*cv_liq + (one-y)*cv_gas
c
        ei  = T * cv_mix
        h   = T * cp_mix
c
        alphaP = one / T
        betaT  = one / pres
c
c        gamb = gamma1
        if (associated(cv))   cv = cv_mix
        if (associated(gamb)) gamb = cp_mix / cv_mix - one
        if (associated(C))    c =  sqrt( gamma * Rgas * T )
c
      end subroutine getthm7_ideal_gas_mixture
c
      function rho_ideal_gas(p,R,T) result(rho)
        implicit none
        real*8 p,R,T,rho
        rho = p / (R*T)
      end function rho_ideal_gas
c
      subroutine getthm6_liquid_1
c
        rho_ref = mat_prop(mater,iprop_liquid_1_rho_ref,1)
        p_ref   = mat_prop(mater,iprop_liquid_1_p_ref,  1)
        T_ref   = mat_prop(mater,iprop_liquid_1_T_ref,  1)
        cv_liq  = mat_prop(mater,iprop_liquid_1_cv,     1)
        alpha_P = mat_prop(mater,iprop_liquid_1_alphaP, 1)
        beta_T  = mat_prop(mater,iprop_liquid_1_betaT,  1)
c
        rho = rho_ref * (one - alpha_P*(T-T_ref) + beta_T*(pres-P_ref))
        ei  = cv_liq*T + if_reaction_heat
c
      end subroutine getthm6_liquid_1
c
      subroutine getthm7_liquid_1
c
        call getthm6_liquid_1
c
        h   = ei + pres/rho
        cp  = cv_liq
        alphaP = alpha_P
        betaT  = beta_T
        if (associated(cv)) cv  = cv_liq
        if (associated(gamb)) gamb = zero
c        c =  sqrt(one/(rho_ref*betaT))
        if (associated(c)) c =  sqrt(one/(rho*betaT))
c
      end subroutine getthm7_liquid_1
c
      subroutine getthm6_solid_1
c
        use e3_solid_m
        implicit none
c
        rho_ref_s = mat_prop(mater,iprop_solid_1_rho_ref,1)
        p_ref_s   = mat_prop(mater,iprop_solid_1_p_ref,  1)
        T_ref_s   = mat_prop(mater,iprop_solid_1_T_ref,  1)
        cv_s     = mat_prop(mater,iprop_solid_1_cv,     1)
        alpha_P_s = mat_prop(mater,iprop_solid_1_alphaP, 1)
        bulkMod_s = mat_prop(mater,iprop_solid_1_bulkMod, 1)
        shearMod_s = mat_prop(mater,iprop_solid_1_shearMod, 1)
c        beta_T  = mat_prop(mater,iprop_solid_1_betaT,  1)
c
        alphaP = alpha_P_s
        betaT  = one /(bulkMod_s * Ja_def) ! double check here
        rho = rho_ref_s * (one - alphaP*(T - T_ref_s)
     &                    + betaT*(pres - p_ref_s))
c        ei  = ( cv_s - pres * alpha_P_s/rho)* T
c    &        + (betaT * pres - alphaP * T)/rho * pres
        ei  = cv_s * T
c
      end subroutine getthm6_solid_1
c
      subroutine getthm7_solid_1
c
        use e3_solid_m
        implicit none
c
        call getthm6_solid_1
c
        h   = ei + pres/rho
        cv  = cv_s
        cp  = cv_s
        bulkMod = bulkMod_s
        shearMod = shearMod_s
c        c =  sqrt(one/(rho_ref*betaT))
C         c =  sqrt(one/(rho*betaT))
C         gamb = zero
c
c
      end subroutine getthm7_solid_1
c
      subroutine getthmif0
        use e3if_param_m
        call e3if_setparam_0
        call getthmif0_ptr
      end subroutine getthmif0
c
      subroutine getthmif1
        use e3if_param_m
        call e3if_setparam_1
        call getthmif1_ptr
      end subroutine getthmif1
c
      subroutine getthmif_solid_0
c
      end subroutine getthmif_solid_0
c
      subroutine getthmif_solid_1
c
      end subroutine getthmif_solid_1
c
      end module eqn_state_m


!! eta derivs is (1-eta^2) d/deta - eta (E1) or O1
!! eta_rhoderivs is d/deta
!! adapted from eta_init
subroutine GetJacobiKE(points,weights,ketot, lbig, eta_derivs,eta_rhoderivs,evenodd)
  implicit none
  integer,intent(in) :: lbig, evenodd
  real*8,intent(out) :: points((lbig+1)), weights((lbig+1)),ketot((lbig+1),(lbig+1)),&
       eta_derivs((lbig+1),(lbig+1)),eta_rhoderivs(lbig+1,lbig+1)
  integer, parameter :: numextra=6
  integer :: numpoints,  one=1, two=2, izero=0, i,j,k,jj , extraorder
  real*8 :: extrapoints((lbig+1)+numextra), extraweights(numextra+(lbig+1)), &
       firstdertot((lbig+1)+numextra,(lbig+1)), scratch(numextra+(lbig+1)), &
       etavals((lbig+1)+numextra,(lbig+1)), endpoints(2)=[-1.0d0,1.0d0] , zero = 0.0, sum

  extrapoints=0; extraweights=0; firstdertot=0; scratch=0; etavals=0

  numpoints=lbig+1
  one=1;two=2
  extraorder=numextra+numpoints

  call gaussq(one,numpoints,zero,zero,izero,endpoints,scratch,points,weights)
  call gaussq(one,extraorder,zero,zero,izero,endpoints,scratch,extrapoints,extraweights)

 ! firstderiv(i,j)  First derivative matrix.  Deriv of ith dvr at x_j

  do k=1,extraorder  ! point k
     do j=1,numpoints  ! which basis function
        sum=1.d0
        do i=1,numpoints
           if (j/=i) then
              sum=sum * (extrapoints(k)-points(i))/(points(j)-points(i))
           endif
        enddo
        etavals(k,j)=sum
     enddo
  enddo

  if (numextra.ne.0) then
     do k=1,extraorder  ! point k
        do j=1,numpoints
           sum=0.d0
           do i=1,numpoints
              if (j/=i) then
                 sum=sum+ etavals(k,j)/(extrapoints(k)-points(i))
              endif
           enddo
           firstdertot(k,j)=sum
        enddo
     enddo
  else
     print *, "Numextra not supported.", numextra;     stop
  endif

  do jj=1,numpoints
     firstdertot(:,jj) = firstdertot(:,jj) / sqrt(weights(jj))
     etavals(:,jj) = etavals(:,jj) / sqrt(weights(jj))
  enddo

  do i=1,numpoints
     do j=1,numpoints
        sum=0
        do k=1,extraorder
           sum=sum + extraweights(k) * etavals(k,i) * ( extrapoints(k)*(1-extrapoints(k)**2) * &
                firstdertot(k,j) + (0.5d0 - 3d0/2d0 * extrapoints(k)**2) * etavals(k,j) )
        enddo
        eta_rhoderivs(i,j)=sum

        sum=0.0d0
        if (evenodd.eq.0) then
           do k=1,extraorder
              sum= sum + etavals(k,i) &
              * (firstdertot(k,j)* (1-extrapoints(k)**2) - etavals(k,j) * extrapoints(k) )  &
                   * extraweights(k)
           enddo
        else
           do k=1,extraorder
              sum= sum + etavals(k,i) &
                   * (firstdertot(k,j)* (1-extrapoints(k)**2)**2 - 2*etavals(k,j) * &
                   (1-extrapoints(k)**2)*extrapoints(k) )  &
                   * extraweights(k)
           enddo
           sum=sum/sqrt((1-points(i)**2)*(1-points(j)**2))
        endif
        eta_derivs(i,j)=sum
     enddo
  enddo

!! negative definite operators for eta.

  do j=1,numpoints
     do i=1,numpoints
        if (evenodd.eq.0) then !! even, d/dx (1-x^2)**2 d/dx
           sum=0.0d0
           do k=1,extraorder
              sum = sum - firstdertot(k,j) * firstdertot(k,i) * extraweights(k) * (1-extrapoints(k)**2)
           enddo
        else
           sum=0.0d0
           do k=1,extraorder
              sum= sum - (firstdertot(k,j)* (1-extrapoints(k)**2) - etavals(k,j) * extrapoints(k) )  &
                   * (firstdertot(k,i)* (1-extrapoints(k)**2) - etavals(k,i) * extrapoints(k) )  &
                   * extraweights(k)
           enddo
           sum=sum/sqrt((1-points(i)**2)*(1-points(j)**2))
        endif
        ketot(i,j)= sum   !! symmetric kinetic energy
     enddo
  enddo

end subroutine GetJacobiKE