c*************************************************************************
c                        LYAP2_KEPU_MIKK
c*************************************************************************
c Given an s, returns mikkola's c1,c2,c3,c4,c5
c
c             Input:
c                 alpha         ==>  Twice the binding energy (real scalar)
c                 s             ==>  Approx. root of f
c             Output:
c                 c1,c2,c3      ==>  c's from p171-172
c                                       (real scalors)
c                 c4,c5         ==>  Mikkola's extra c'c
c                                       (real scalors)
c
c Based on Mikkola's code
c Author:  Hal Levison
c Date:    7/11/95
c Last revision:

      subroutine lyap2_kepu_mikk(s,alpha,c1,c2,c3,c4,c5)

      include '../swift.inc'

c...  Inputs:
      real*8 alpha,s

c...  Outputs:
      real*8 c1,c2,c3,c4,c5

c...  Internals:
      real*8  x,h
      real*8 cc6,cc132,cc56,cc30,cc24,cc156,cc90,cc110,cc16
      real*8 cc8,cc72,cc42,cc120,cc2,cc3
      integer k,i

      parameter(cc6=1.d0/6.d0,cc132=1.d0/132.d0,cc56=1.d0/56.d0,
     &  cc30=1.d0/30d0,cc24=1.d0/24.d0,cc156=1.d0/156.d0,
     &  cc90=1.d0/90.d0,cc110=1.d0/110.d0,cc16=1.d0/16.d0,
     &  cc8=1.d0/8.d0,cc72=1.d0/72.d0,cc42=1.d0/42.d0,
     &  cc120=1.d0/120.d0)

c----
c...  Executable code

      x=s*s*alpha

c...  From Mikkola's code

      h=x
      do k=0,10
         if(abs(h) .ge. 0.1) goto 1
         h=0.25d0*h
      enddo
 1    continue

      c4 = (1.0d0-h*(1.0d0-h*(1.0d0-h*cc90/(1.0d0+h*cc132))*
     &     cc56)*cc30)*cc24
      c5 = (1.0d0-h*(1.0d0-h*(1.0d0-h*cc110/(1.0d0+h*cc156))*
     &     cc72)*cc42)*cc120

      do i=1,k
         cc3 =  cc6 - h*c5
         cc2 = 0.5D0 - h*c4
         c5 = (c5 + c4+cc2*cc3)*cc16
         c4 = cc3*(2.d0-h*cc3)*cc8
         h=4.d0*h
      enddo

      c3 = cc6 - x*c5
      c2 = 0.5d0 - x*c4
      c1 = 1.d0 - x*c3

c...  End of Mikkola's code

      c1=c1*s
      c2 = c2*s*s
      c3 = c3*s*s*s
      c4 = c4*s*s*s*s
      c5 = c5*s*s*s*s*s

      return
      end                       !   lyap2_kepu_mikk
c-------------------------------------------------------------------


module riemann_mod

use constants_mod

contains

!! Eulerian Slippery Wall
pure function eulerian_slip_wall(inner,outer) result(F)

    use equations_const_mod
    use equations_mod, only: pressure
    use setup_config_mod, only: kappa

    real(dp), intent(in) :: inner(N_VARS)
    real(dp), intent(in) :: outer(N_VARS)
    real(dp)             :: F(N_VARS)

    real(dp) :: v,p,c, a,b

    v = inner(MOMX_VAR)/inner(DENS_VAR)
    p = pressure(inner)

    if (v <= 0.0_dp) then

        c = SQRT(kappa*p/inner(DENS_VAR))
        p = p*max((1.0_dp + 0.5_dp*(kappa-1.0_dp)*v/c),1e-5_dp)**(2.0_dp*kappa/(kappa-1.0_dp))

    else

        a = 2.0_dp/(kappa+1.0_dp)/inner(DENS_VAR)
        b = (kappa-1.0_dp)/(kappa+1.0_dp)*p
        p = p + v/a*0.5_dp*(v + SQRT(v**2 + 4.0_dp*a*(p+b)))

    end if

    F = 0.0_dp
    F(MOMX_VAR) = p

end function

#:if PP_MODULE == 'riemann_north_mod'
pure function xriemann(U_L,U_R) result(F)

    use equations_const_mod

    real(dp), intent(in) :: U_L(N_VARS)
    real(dp), intent(in) :: U_R(N_VARS)
    real(dp)             :: F(N_VARS)

    real(dp) :: inner(N_VARS), outer(N_VARS)

    inner(DENS_VAR) =  U_R(DENS_VAR)
    inner(MOMX_VAR) = -U_R(MOMX_VAR)
    inner(MOMY_VAR) =  U_R(MOMY_VAR)
    inner(MOMZ_VAR) =  U_R(MOMZ_VAR)
    inner(ENER_VAR) =  U_R(ENER_VAR)

    outer(DENS_VAR) =  U_L(DENS_VAR)
    outer(MOMX_VAR) = -U_L(MOMX_VAR)
    outer(MOMY_VAR) =  U_L(MOMY_VAR)
    inner(MOMZ_VAR) =  U_R(MOMZ_VAR)
    outer(ENER_VAR) =  U_L(ENER_VAR)

    f = eulerian_slip_wall(inner,outer)

end function
#:endif

#:if PP_MODULE == 'riemann_south_mod'
pure function xriemann(U_L,U_R) result(F)

    real(dp), intent(in) :: U_L(N_VARS)
    real(dp), intent(in) :: U_R(N_VARS)
    real(dp)             :: F(N_VARS)

    f = eulerian_slip_wall(U_L,U_R)

end function
#:endif

#:if PP_MODULE == 'riemann_west_mod'
pure function yriemann(U_L,U_R) result(F)

    use equations_const_mod

    real(dp), intent(in) :: U_L(N_VARS)
    real(dp), intent(in) :: U_R(N_VARS)
    real(dp)             :: F(N_VARS)

    real(dp) :: inner(N_VARS), outer(N_VARS), rflux(N_VARS)

    inner(DENS_VAR) =  U_R(DENS_VAR)
    inner(MOMX_VAR) = -U_R(MOMY_VAR)
    inner(MOMY_VAR) =  U_R(MOMZ_VAR)
    inner(MOMZ_VAR) =  U_R(MOMX_VAR)
    inner(ENER_VAR) =  U_R(ENER_VAR)

    outer(DENS_VAR) =  U_L(DENS_VAR)
    outer(MOMX_VAR) = -U_L(MOMY_VAR)
    outer(MOMY_VAR) =  U_L(MOMZ_VAR)
    outer(MOMZ_VAR) =  U_L(MOMX_VAR)
    outer(ENER_VAR) =  U_L(ENER_VAR)

    rflux = eulerian_slip_wall(inner,outer)

    f(DENS_VAR) = rflux(DENS_VAR)
    f(MOMX_VAR) = rflux(MOMZ_VAR)
    f(MOMY_VAR) = rflux(MOMX_VAR)
    f(MOMZ_VAR) = rflux(MOMY_VAR)
    f(ENER_VAR) = rflux(ENER_VAR)

 end function
#:endif

#:if PP_MODULE == 'riemann_east_mod'
pure function yriemann(U_L,U_R) result(F)

    use equations_const_mod

    real(dp), intent(in) :: U_L(N_VARS)
    real(dp), intent(in) :: U_R(N_VARS)
    real(dp)             :: F(N_VARS)

    real(dp) :: inner(N_VARS), outer(N_VARS), rflux(N_VARS)

    inner(DENS_VAR) = U_L(DENS_VAR)
    inner(MOMX_VAR) = U_L(MOMY_VAR)
    inner(MOMY_VAR) = U_L(MOMZ_VAR)
    inner(MOMZ_VAR) = U_L(MOMX_VAR)
    inner(ENER_VAR) = U_L(ENER_VAR)

    outer(DENS_VAR) = U_R(DENS_VAR)
    outer(MOMX_VAR) = U_R(MOMY_VAR)
    outer(MOMY_VAR) = U_R(MOMZ_VAR)
    outer(MOMZ_VAR) = U_R(MOMX_VAR)
    outer(ENER_VAR) = U_R(ENER_VAR)

    rflux = eulerian_slip_wall(inner,outer)

    f(DENS_VAR) = rflux(DENS_VAR)
    f(MOMX_VAR) = rflux(MOMZ_VAR)
    f(MOMY_VAR) = rflux(MOMX_VAR)
    f(MOMZ_VAR) = rflux(MOMY_VAR)
    f(ENER_VAR) = rflux(ENER_VAR)

end function
#:endif

#:if PP_MODULE == 'riemann_front_mod'
pure function zriemann(U_L,U_R) result(F)

    use equations_const_mod

    real(dp), intent(in) :: U_L(N_VARS)
    real(dp), intent(in) :: U_R(N_VARS)
    real(dp)             :: F(N_VARS)

    real(dp) :: inner(N_VARS), outer(N_VARS), rflux(N_VARS)

    inner(DENS_VAR) =  U_R(DENS_VAR)
    inner(MOMX_VAR) = -U_R(MOMZ_VAR)
    inner(MOMY_VAR) =  U_R(MOMX_VAR)
    inner(MOMZ_VAR) =  U_R(MOMY_VAR)
    inner(ENER_VAR) =  U_R(ENER_VAR)

    outer(DENS_VAR) =  U_L(DENS_VAR)
    outer(MOMX_VAR) = -U_L(MOMZ_VAR)
    outer(MOMY_VAR) =  U_L(MOMX_VAR)
    outer(MOMZ_VAR) =  U_L(MOMY_VAR)
    outer(ENER_VAR) =  U_L(ENER_VAR)

    rflux = eulerian_slip_wall(inner,outer)

    f(DENS_VAR) = rflux(DENS_VAR)
    f(MOMX_VAR) = rflux(MOMY_VAR)
    f(MOMY_VAR) = rflux(MOMZ_VAR)
    f(MOMZ_VAR) = rflux(MOMX_VAR)
    f(ENER_VAR) = rflux(ENER_VAR)

 end function
#:endif

#:if PP_MODULE == 'riemann_back_mod'
pure function zriemann(U_L,U_R) result(F)

    use equations_const_mod

    real(dp), intent(in) :: U_L(N_VARS)
    real(dp), intent(in) :: U_R(N_VARS)
    real(dp)             :: F(N_VARS)

    real(dp) :: inner(N_VARS), outer(N_VARS), rflux(N_VARS)

    inner(DENS_VAR) = U_L(DENS_VAR)
    inner(MOMX_VAR) = U_L(MOMZ_VAR)
    inner(MOMY_VAR) = U_L(MOMX_VAR)
    inner(MOMZ_VAR) = U_L(MOMY_VAR)
    inner(ENER_VAR) = U_L(ENER_VAR)

    outer(DENS_VAR) = U_R(DENS_VAR)
    outer(MOMX_VAR) = U_R(MOMZ_VAR)
    outer(MOMY_VAR) = U_R(MOMX_VAR)
    outer(MOMZ_VAR) = U_R(MOMY_VAR)
    outer(ENER_VAR) = U_R(ENER_VAR)

    rflux = eulerian_slip_wall(inner,outer)

    f(DENS_VAR) = rflux(DENS_VAR)
    f(MOMX_VAR) = rflux(MOMY_VAR)
    f(MOMY_VAR) = rflux(MOMZ_VAR)
    f(MOMZ_VAR) = rflux(MOMX_VAR)
    f(ENER_VAR) = rflux(ENER_VAR)

end function
#:endif

end module


      SUBROUTINE NF01BP( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB,
     $                   DELTA, PAR, RANKS, X, RX, TOL, DWORK, LDWORK,
     $                   INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To determine a value for the Levenberg-Marquardt parameter PAR
C     such that if x solves the system
C
C           J*x = b ,     sqrt(PAR)*D*x = 0 ,
C
C     in the least squares sense, where J is an m-by-n matrix, D is an
C     n-by-n nonsingular diagonal matrix, and b is an m-vector, and if
C     DELTA is a positive number, DXNORM is the Euclidean norm of D*x,
C     then either PAR is zero and
C
C           ( DXNORM - DELTA ) .LE. 0.1*DELTA ,
C
C     or PAR is positive and
C
C           ABS( DXNORM - DELTA ) .LE. 0.1*DELTA .
C
C     The matrix J is the current Jacobian matrix of a nonlinear least
C     squares problem, provided in a compressed form by SLICOT Library
C     routine NF01BD. It is assumed that a block QR factorization, with
C     column pivoting, of J is available, that is, J*P = Q*R, where P is
C     a permutation matrix, Q has orthogonal columns, and R is an upper
C     triangular matrix with diagonal elements of nonincreasing
C     magnitude for each block, as returned by SLICOT Library
C     routine NF01BS. The routine NF01BP needs the upper triangle of R
C     in compressed form, the permutation matrix P, and the first
C     n components of Q'*b (' denotes the transpose). On output,
C     NF01BP also provides a compressed representation of an upper
C     triangular matrix S, such that
C
C           P'*(J'*J + PAR*D*D)*P = S'*S .
C
C     Matrix S is used in the solution process. The matrix R has the
C     following structure
C
C         /   R_1    0    ..   0   |   L_1   \
C         |    0    R_2   ..   0   |   L_2   |
C         |    :     :    ..   :   |    :    | ,
C         |    0     0    ..  R_l  |   L_l   |
C         \    0     0    ..   0   |  R_l+1  /
C
C     where the submatrices R_k, k = 1:l, have the same order BSN,
C     and R_k, k = 1:l+1, are square and upper triangular. This matrix
C     is stored in the compressed form
C
C              /   R_1  |   L_1   \
C              |   R_2  |   L_2   |
C       Rc =   |    :   |    :    | ,
C              |   R_l  |   L_l   |
C              \    X   |  R_l+1  /
C
C     where the submatrix X is irrelevant. The matrix S has the same
C     structure as R, and its diagonal blocks are denoted by S_k,
C     k = 1:l+1.
C
C     If l <= 1, then the full upper triangle of the matrix R is stored.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COND    CHARACTER*1
C             Specifies whether the condition of the diagonal blocks R_k
C             and S_k of the matrices R and S should be estimated,
C             as follows:
C             = 'E' :  use incremental condition estimation for each
C                      diagonal block of R_k and S_k to find its
C                      numerical rank;
C             = 'N' :  do not use condition estimation, but check the
C                      diagonal entries of R_k and S_k for zero values;
C             = 'U' :  use the ranks already stored in RANKS (for R).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix R.  N = BN*BSN + ST >= 0.
C             (See parameter description below.)
C
C     IPAR    (input) INTEGER array, dimension (LIPAR)
C             The integer parameters describing the structure of the
C             matrix R, as follows:
C             IPAR(1) must contain ST, the number of columns of the
C                     submatrices L_k and the order of R_l+1.  ST >= 0.
C             IPAR(2) must contain BN, the number of blocks, l, in the
C                     block diagonal part of R.  BN >= 0.
C             IPAR(3) must contain BSM, the number of rows of the blocks
C                     R_k, k = 1:l.  BSM >= 0.
C             IPAR(4) must contain BSN, the number of columns of the
C                     blocks R_k, k = 1:l.  BSN >= 0.
C             BSM is not used by this routine, but assumed equal to BSN.
C
C     LIPAR   (input) INTEGER
C             The length of the array IPAR.  LIPAR >= 4.
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR, NC)
C             where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1.
C             On entry, the leading N-by-NC part of this array must
C             contain the (compressed) representation (Rc) of the upper
C             triangular matrix R. If BN > 1, the submatrix X in Rc is
C             not referenced. The zero strict lower triangles of R_k,
C             k = 1:l+1, need not be set. If BN <= 1 or BSN = 0, then
C             the full upper triangle of R must be stored.
C             On exit, the full upper triangles of R_k, k = 1:l+1, and
C             L_k, k = 1:l, are unaltered, and the strict lower
C             triangles of R_k, k = 1:l+1, contain the corresponding
C             strict upper triangles (transposed) of the upper
C             triangular matrix S.
C             If BN <= 1 or BSN = 0, then the transpose of the strict
C             upper triangle of S is stored in the strict lower triangle
C             of R.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,N).
C
C     IPVT    (input) INTEGER array, dimension (N)
C             This array must define the permutation matrix P such that
C             J*P = Q*R. Column j of P is column IPVT(j) of the identity
C             matrix.
C
C     DIAG    (input) DOUBLE PRECISION array, dimension (N)
C             This array must contain the diagonal elements of the
C             matrix D.  DIAG(I) <> 0, I = 1,...,N.
C
C     QTB     (input) DOUBLE PRECISION array, dimension (N)
C             This array must contain the first n elements of the
C             vector Q'*b.
C
C     DELTA   (input) DOUBLE PRECISION
C             An upper bound on the Euclidean norm of D*x.  DELTA > 0.
C
C     PAR     (input/output) DOUBLE PRECISION
C             On entry, PAR must contain an initial estimate of the
C             Levenberg-Marquardt parameter.  PAR >= 0.
C             On exit, it contains the final estimate of this parameter.
C
C     RANKS   (input or output) INTEGER array, dimension (r), where
C             r = BN + 1,  if ST > 0, BSN > 0, and BN > 1;
C             r = BN,      if ST = 0 and BSN > 0;
C             r = 1,       if ST > 0 and ( BSN = 0 or BN <= 1 );
C             r = 0,       if ST = 0 and BSN = 0.
C             On entry, if COND = 'U' and N > 0, this array must contain
C             the numerical ranks of the submatrices R_k, k = 1:l(+1).
C             On exit, if N > 0, this array contains the numerical ranks
C             of the submatrices S_k, k = 1:l(+1).
C
C     X       (output) DOUBLE PRECISION array, dimension (N)
C             This array contains the least squares solution of the
C             system J*x = b, sqrt(PAR)*D*x = 0.
C
C     RX      (output) DOUBLE PRECISION array, dimension (N)
C             This array contains the matrix-vector product -R*P'*x.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             If COND = 'E', the tolerance to be used for finding the
C             ranks of the submatrices R_k and S_k. If the user sets
C             TOL > 0, then the given value of TOL is used as a lower
C             bound for the reciprocal condition number;  a (sub)matrix
C             whose estimated condition number is less than 1/TOL is
C             considered to be of full rank.  If the user sets TOL <= 0,
C             then an implicitly computed, default tolerance, defined by
C             TOLDEF = N*EPS,  is used instead, where EPS is the machine
C             precision (see LAPACK Library routine DLAMCH).
C             This parameter is not relevant if COND = 'U' or 'N'.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, the first N elements of this array contain the
C             diagonal elements of the upper triangular matrix S.
C             If BN > 1 and BSN > 0, the elements N+1 : N+ST*(N-ST)
C             contain the submatrix (S(1:N-ST,N-ST+1:N))' of the
C             matrix S.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 2*N,              if BN <= 1 or  BSN = 0 and
C                                                        COND <> 'E';
C             LDWORK >= 4*N,              if BN <= 1 or  BSN = 0 and
C                                                        COND =  'E';
C             LDWORK >= ST*(N-ST) + 2*N,  if BN >  1 and BSN > 0 and
C                                                        COND <> 'E';
C             LDWORK >= ST*(N-ST) + 2*N + 2*MAX(BSN,ST),
C                                         if BN >  1 and BSN > 0 and
C                                                        COND =  'E'.
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
C     METHOD
C
C     The algorithm computes the Gauss-Newton direction. An approximate
C     basic least squares solution is found if the Jacobian is rank
C     deficient. The computations exploit the special structure and
C     storage scheme of the matrix R. If one or more of the submatrices
C     R_k or S_k, k = 1:l+1, is singular, then the computed result is
C     not the basic least squares solution for the whole problem, but a
C     concatenation of (least squares) solutions of the individual
C     subproblems involving R_k or S_k, k = 1:l+1 (with adapted right
C     hand sides).
C
C     If the Gauss-Newton direction is not acceptable, then an iterative
C     algorithm obtains improved lower and upper bounds for the
C     Levenberg-Marquardt parameter PAR. Only a few iterations are
C     generally needed for convergence of the algorithm. If, however,
C     the limit of ITMAX = 10 iterations is reached, then the output PAR
C     will contain the best value obtained so far. If the Gauss-Newton
C     step is acceptable, it is stored in x, and PAR is set to zero,
C     hence S = R.
C
C     REFERENCES
C
C     [1] More, J.J., Garbow, B.S, and Hillstrom, K.E.
C         User's Guide for MINPACK-1.
C         Applied Math. Division, Argonne National Laboratory, Argonne,
C         Illinois, Report ANL-80-74, 1980.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires 0(N*(BSN+ST)) operations and is backward
C     stable, if R is nonsingular.
C
C     FURTHER COMMENTS
C
C     This routine is a structure-exploiting, LAPACK-based modification
C     of LMPAR from the MINPACK package [1], and with optional condition
C     estimation. The option COND = 'U' is useful when dealing with
C     several right-hand side vectors, but RANKS array should be reset.
C     If COND = 'E', but the matrix S is guaranteed to be nonsingular
C     and well conditioned relative to TOL, i.e., rank(R) = N, and
C     min(DIAG) > 0, then its condition is not estimated.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001.
C
C     REVISIONS
C
C     V. Sima, Feb. 2004.
C
C     KEYWORDS
C
C     Linear system of equations, matrix operations, plane rotations.
C
C     ******************************************************************
C
C     .. Parameters ..
      INTEGER           ITMAX
      PARAMETER         ( ITMAX = 10 )
      DOUBLE PRECISION  P1, P001, ZERO, ONE
      PARAMETER         ( P1  = 1.0D-1, P001 = 1.0D-3, ZERO = 0.0D0,
     $                    ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         COND
      INTEGER           INFO, LDR, LDWORK, LIPAR, N
      DOUBLE PRECISION  DELTA, PAR, TOL
C     .. Array Arguments ..
      INTEGER           IPAR(*), IPVT(*), RANKS(*)
      DOUBLE PRECISION  DIAG(*), DWORK(*), QTB(*), R(LDR,*), RX(*), X(*)
C     .. Local Scalars ..
      INTEGER           BN, BSM, BSN, I, IBSN, ITER, J, JW, K, L, LDS,
     $                  N2, NTHS, RANK, ST
      DOUBLE PRECISION  DMINO, DWARF, DXNORM, FP, GNORM, PARC, PARL,
     $                  PARU, SUM, TEMP, TOLDEF
      LOGICAL           BADRK, ECOND, NCOND, SING, UCOND
      CHARACTER         CONDL
C     .. External Functions ..
      DOUBLE PRECISION  DDOT, DLAMCH, DNRM2
      LOGICAL           LSAME
      EXTERNAL          DDOT, DLAMCH, DNRM2, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMV, DTRMV, MD03BY, NF01BQ, NF01BR,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE, MAX, MIN, SQRT
C     ..
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      ECOND = LSAME( COND, 'E' )
      NCOND = LSAME( COND, 'N' )
      UCOND = LSAME( COND, 'U' )
      INFO  = 0
      N2    = 2*N
      IF( .NOT.( ECOND .OR. NCOND .OR. UCOND ) ) THEN
         INFO = -1
      ELSEIF( N.LT.0 ) THEN
         INFO = -2
      ELSEIF( LIPAR.LT.4 ) THEN
         INFO = -4
      ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSEIF( DELTA.LE.ZERO ) THEN
         INFO = -10
      ELSEIF( PAR.LT.ZERO ) THEN
         INFO = -11
      ELSE
         ST   = IPAR(1)
         BN   = IPAR(2)
         BSM  = IPAR(3)
         BSN  = IPAR(4)
         NTHS = BN*BSN
         IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN
            INFO = -3
         ELSEIF ( N.NE.NTHS + ST ) THEN
            INFO = -2
         ELSE
            IF ( N.GT.0 )
     $         DMINO = DIAG(1)
            SING = .FALSE.
C
            DO 10 J = 1, N
               IF ( DIAG(J).LT.DMINO )
     $            DMINO = DIAG(J)
               SING = SING .OR. DIAG(J).EQ.ZERO
   10       CONTINUE
C
            IF ( SING ) THEN
               INFO = -8
            ELSEIF ( UCOND ) THEN
               BADRK = .FALSE.
               IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN
                  IF ( N.GT.0 )
     $               BADRK = RANKS(1).LT.0 .OR. RANKS(1).GT.N
               ELSE
                  RANK  = 0
C
                  DO 20 K = 1, BN
                     BADRK = BADRK .OR. RANKS(K).LT.0
     $                             .OR. RANKS(K).GT.BSN
                     RANK  = RANK + RANKS(K)
   20             CONTINUE
C
                  IF ( ST.GT.0 ) THEN
                     BADRK = BADRK .OR. RANKS(BN+1).LT.0 .OR.
     $                                  RANKS(BN+1).GT.ST
                     RANK  = RANK + RANKS(BN+1)
                  END IF
               END IF
               IF ( BADRK )
     $            INFO = -12
            ELSE
               JW = N2
               IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN
                  IF ( ECOND )
     $               JW = 4*N
               ELSE
                  JW = ST*NTHS + JW
                  IF ( ECOND )
     $               JW = 2*MAX( BSN, ST ) + JW
               END IF
               IF ( LDWORK.LT.JW )
     $            INFO = -17
            ENDIF
         ENDIF
      ENDIF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'NF01BP', -INFO )
         RETURN
      ENDIF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         PAR = ZERO
         RETURN
      END IF
C
      IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN
C
C        Special case: R is just an upper triangular matrix.
C        Workspace: 4*N, if COND =  'E';
C                   2*N, if COND <> 'E'.
C
         CALL MD03BY( COND, N, R, LDR, IPVT, DIAG, QTB, DELTA, PAR,
     $                RANKS(1), X, RX, TOL, DWORK, LDWORK, INFO )
         RETURN
      END IF
C
C     General case: l > 1 and BSN > 0.
C     DWARF is the smallest positive magnitude.
C
      DWARF = DLAMCH( 'Underflow' )
C
C     Compute and store in x the Gauss-Newton direction. If the
C     Jacobian is rank-deficient, obtain a least squares solution.
C     The array RX is used as workspace.
C     Workspace: 2*MAX(BSN,ST), if COND =  'E';
C                0,             if COND <> 'E'.
C
      CALL DCOPY( N, QTB, 1, RX, 1 )
      CALL NF01BR( COND, 'Upper', 'No transpose', N, IPAR, LIPAR, R,
     $             LDR, DWORK, DWORK, 1, RX, RANKS, TOL, DWORK, LDWORK,
     $             INFO )
C
      DO 30 J = 1, N
         L    = IPVT(J)
         X(L) = RX(J)
   30 CONTINUE
C
C     Initialize the iteration counter.
C     Evaluate the function at the origin, and test
C     for acceptance of the Gauss-Newton direction.
C
      ITER = 0
C
      DO 40 J = 1, N
         DWORK(J) = DIAG(J)*X(J)
   40 CONTINUE
C
      DXNORM = DNRM2( N, DWORK, 1 )
      FP     = DXNORM - DELTA
      IF ( FP.GT.P1*DELTA ) THEN
C
C        Set an appropriate option for estimating the condition of
C        the matrix S.
C
         LDS = MAX( 1, ST )
         JW  = N2 + ST*NTHS
         IF ( UCOND ) THEN
            IF ( LDWORK.GE.JW + 2*MAX( BSN, ST ) ) THEN
               CONDL  = 'E'
               TOLDEF = DBLE( N )*DLAMCH( 'Epsilon' )
            ELSE
               CONDL  = 'N'
               TOLDEF = TOL
            END IF
         ELSE
            RANK = 0
C
            DO 50 K = 1, BN
               RANK = RANK + RANKS(K)
   50       CONTINUE
C
            IF ( ST.GT.0 )
     $         RANK = RANK + RANKS(BN+1)
            CONDL  = COND
            TOLDEF = TOL
         END IF
C
C        If the Jacobian is not rank deficient, the Newton
C        step provides a lower bound, PARL, for the zero of
C        the function. Otherwise set this bound to zero.
C
         IF ( RANK.EQ.N ) THEN
C
            DO 60 J = 1, N
               L = IPVT(J)
               RX(J) = DIAG(L)*( DWORK(L)/DXNORM )
   60       CONTINUE
C
            CALL NF01BR( 'Use ranks', 'Upper', 'Transpose', N, IPAR,
     $                   LIPAR, R, LDR, DWORK, DWORK, 1, RX, RANKS, TOL,
     $                   DWORK, LDWORK, INFO )
            TEMP = DNRM2( N, RX, 1 )
            PARL = ( ( FP/DELTA )/TEMP )/TEMP
C
C           For efficiency, use CONDL = 'U', if possible.
C
            IF ( .NOT.LSAME( CONDL, 'U' ) .AND. DMINO.GT.ZERO )
     $         CONDL = 'U'
         ELSE
            PARL = ZERO
         END IF
C
         IBSN = 0
         K    = 1
C
C        Calculate an upper bound, PARU, for the zero of the function.
C
         DO 70 J = 1, N
            IBSN = IBSN + 1
            IF ( J.LT.NTHS ) THEN
               SUM = DDOT( IBSN, R(K,IBSN), 1, QTB(K), 1 )
               IF ( IBSN.EQ.BSN ) THEN
                  IBSN = 0
                  K    = K + BSN
               END IF
            ELSE IF ( J.EQ.NTHS ) THEN
               SUM = DDOT( IBSN, R(K,IBSN), 1, QTB(K), 1 )
            ELSE
               SUM = DDOT( J, R(1,IBSN), 1, QTB, 1 )
            END IF
            L = IPVT(J)
            RX(J) = SUM/DIAG(L)
   70    CONTINUE
C
         GNORM = DNRM2( N, RX, 1 )
         PARU  = GNORM/DELTA
         IF ( PARU.EQ.ZERO )
     $      PARU = DWARF/MIN( DELTA, P1 )/P001
C
C        If the input PAR lies outside of the interval (PARL,PARU),
C        set PAR to the closer endpoint.
C
         PAR = MAX( PAR, PARL )
         PAR = MIN( PAR, PARU )
         IF ( PAR.EQ.ZERO )
     $      PAR = GNORM/DXNORM
C
C        Beginning of an iteration.
C
   80    CONTINUE
            ITER = ITER + 1
C
C           Evaluate the function at the current value of PAR.
C
            IF ( PAR.EQ.ZERO )
     $         PAR = MAX( DWARF, P001*PARU )
            TEMP = SQRT( PAR )
C
            DO 90 J = 1, N
               RX(J) = TEMP*DIAG(J)
   90       CONTINUE
C
C           Solve the system J*x = b , sqrt(PAR)*D*x = 0 , in a least
C           square sense.
C           The first N elements of DWORK contain the diagonal elements
C           of the upper triangular matrix S, and the next N elements
C           contain the the vector z, so that x = P*z (see NF01BQ).
C           The vector z is not preserved, to reduce the workspace.
C           The elements 2*N+1 : 2*N+ST*(N-ST) contain the
C           submatrix (S(1:N-ST,N-ST+1:N))' of the matrix S.
C           Workspace: ST*(N-ST) + 2*N,                 if CONDL <> 'E';
C                      ST*(N-ST) + 2*N + 2*MAX(BSN,ST), if CONDL =  'E'.
C
            CALL NF01BQ( CONDL, N, IPAR, LIPAR, R, LDR, IPVT, RX, QTB,
     $                   RANKS, X, TOLDEF, DWORK, LDWORK, INFO )
C
            DO 100 J = 1, N
               DWORK(N+J) = DIAG(J)*X(J)
  100       CONTINUE
C
            DXNORM = DNRM2( N, DWORK(N+1), 1 )
            TEMP   = FP
            FP     = DXNORM - DELTA
C
C           If the function is small enough, accept the current value
C           of PAR. Also test for the exceptional cases where PARL
C           is zero or the number of iterations has reached ITMAX.
C
            IF ( ABS( FP ).GT.P1*DELTA .AND.
     $         ( PARL.NE.ZERO .OR. FP.GT.TEMP .OR. TEMP.GE.ZERO ) .AND.
     $           ITER.LT.ITMAX ) THEN
C
C              Compute the Newton correction.
C
               DO 110 J = 1, N
                  L = IPVT(J)
                  RX(J) = DIAG(L)*( DWORK(N+L)/DXNORM )
  110          CONTINUE
C
               CALL NF01BR( 'Use ranks', 'Lower', 'Transpose', N, IPAR,
     $                      LIPAR, R, LDR, DWORK, DWORK(N2+1), LDS, RX,
     $                      RANKS, TOL, DWORK(JW), LDWORK-JW, INFO )
               TEMP = DNRM2( N, RX, 1 )
               PARC = ( ( FP/DELTA )/TEMP )/TEMP
C
C              Depending on the sign of the function, update PARL
C              or PARU.
C
               IF ( FP.GT.ZERO ) THEN
                  PARL = MAX( PARL, PAR )
               ELSE IF ( FP.LT.ZERO ) THEN
                  PARU = MIN( PARU, PAR )
               END IF
C
C              Compute an improved estimate for PAR.
C
               PAR = MAX( PARL, PAR + PARC )
C
C              End of an iteration.
C
               GO TO 80
            END IF
      END IF
C
C     Compute -R*P'*x = -R*z.
C
      DO 120 J = 1, N
         L     = IPVT(J)
         RX(J) = -X(L)
  120 CONTINUE
C
      DO 130 I = 1, NTHS, BSN
         CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', BSN, R(I,1),
     $               LDR, RX(I), 1 )
  130 CONTINUE
C
      IF ( ST.GT.0 ) THEN
         CALL DGEMV( 'NoTranspose', NTHS, ST, ONE, R(1,BSN+1), LDR,
     $               RX(NTHS+1), 1, ONE, RX, 1 )
         CALL DTRMV( 'Upper', 'NoTranspose', 'NonUnit', ST,
     $               R(NTHS+1,BSN+1), LDR, RX(NTHS+1), 1 )
      END IF
C
C     Termination. If PAR = 0, set S.
C
      IF ( ITER.EQ.0 ) THEN
         PAR = ZERO
         I   = 1
C
         DO 150 K = 1, BN
C
            DO 140 J = 1, BSN
               DWORK(I) = R(I,J)
               CALL DCOPY( BSN-J+1, R(I,J), LDR, R(I,J), 1 )
               I = I + 1
  140       CONTINUE
C
  150    CONTINUE
C
         IF ( ST.GT.0 ) THEN
C
            DO 160 J = BSN + 1, BSN + ST
               CALL DCOPY( NTHS, R(1,J), 1, DWORK(N+J-BSN), ST )
               DWORK(I) = R(I,J)
               CALL DCOPY( BSN+ST-J+1, R(I,J), LDR, R(I,J), 1 )
               I = I + 1
  160       CONTINUE
C
         END IF
      ELSE
C
         DO 170 K = N + 1, N + ST*NTHS
            DWORK(K) = DWORK(K+N)
  170    CONTINUE
C
      END IF
C
      RETURN
C
C *** Last line of NF01BP ***
      END


    MODULE random_permutation_mod
! .. Implicit None Statement ..
      IMPLICIT NONE
! ..
    CONTAINS

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

      SUBROUTINE random_permutation(iarray,larray)
! .. Use Statements ..
        USE random_uniform_integer_mod
! ..
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Scalar Arguments ..
        INTEGER :: larray
! ..
! .. Array Arguments ..
        INTEGER, INTENT (INOUT) :: iarray(larray)
! ..
! .. Local Scalars ..
        INTEGER :: i, itmp, iwhich
! ..
! .. Executable Statements ..

!**********************************************************************
!    SUBROUTINE GENPRM( IARRAY, LARRAY )
!               GENerate random PeRMutation of iarray
!                              Arguments
!     IARRAY <--> On output IARRAY is a random permutation of its
!                 value on input
!                         INTEGER IARRAY( LARRAY )
!     LARRAY <--> Length of IARRAY
!                         INTEGER LARRAY
!**********************************************************************
        DO i = 1, larray
          iwhich = random_uniform_integer(i,larray)
          itmp = iarray(iwhich)
          iarray(iwhich) = iarray(i)
          iarray(i) = itmp
        END DO
        RETURN

      END SUBROUTINE random_permutation

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

    END MODULE random_permutation_mod


MODULE Refreezingmod
    IMPLICIT NONE
CONTAINS

    SUBROUTINE model_refreezing(tavg, &
        Tmf, &
        SWrf, &
        Mrf)
        IMPLICIT NONE
        REAL, INTENT(IN) :: tavg
        REAL, INTENT(IN) :: Tmf
        REAL, INTENT(IN) :: SWrf
        REAL, INTENT(OUT) :: Mrf
        !- Name: Refreezing -Version: 1.0, -Time step: 1
        !- Description:
    !            * Title: snowfall accumulation  calculation
    !            * Author: STICS
    !            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    !            * Institution: INRA
    !            * Abstract: It simulates the depth of snow cover and recalculate weather data
        !- inputs:
    !            * name: tavg
    !                          ** description : average temperature
    !                          ** inputtype : variable
    !                          ** variablecategory : auxiliary
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min : 0.0
    !                          ** max : 100.0
    !                          ** unit : degC
    !                          ** uri :
    !            * name: Tmf
    !                          ** description : threshold temperature for snow melting
    !                          ** inputtype : parameter
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min : 0.0
    !                          ** max : 5000.0
    !                          ** unit : degC
    !                          ** uri :
    !            * name: SWrf
    !                          ** description : degree-day temperature index for refreezing
    !                          ** inputtype : parameter
    !                          ** parametercategory : constant
    !                          ** datatype : DOUBLE
    !                          ** default : 0.0
    !                          ** min : 0.0
    !                          ** max : 5000.0
    !                          ** unit : mmW/degC/d
    !                          ** uri :
        !- outputs:
    !            * name: Mrf
    !                          ** description : liquid water in the snow cover in the process of refreezing
    !                          ** variablecategory : rate
    !                          ** datatype : DOUBLE
    !                          ** min : 0.0
    !                          ** max : 500.0
    !                          ** unit : mmW/d
    !                          ** uri :
        Mrf = 0.0
        IF(tavg .LT. Tmf) THEN
            Mrf = SWrf * (Tmf - tavg)
        END IF
    END SUBROUTINE model_refreezing

END MODULE


module Complex_module
    implicit none
    type :: ComplexType
        real :: r
        real :: i

        contains

        procedure :: integer_add_subrout
        procedure :: real_add_subrout
        generic :: add => integer_add_subrout, real_add_subrout
    end type

    contains

    subroutine integer_add_subrout(this, r, i, sum)
        class(ComplexType), intent(in) :: this
        integer, intent(in) :: r, i
        type(ComplexType), intent(out) :: sum
        print *, "Calling integer_add_subrout"
        sum%r = this%r + r
        sum%i = this%i + i
    end subroutine

    subroutine real_add_subrout(this, r, i, sum)
        class(ComplexType), intent(in) :: this
        real, intent(in) :: r, i
        type(ComplexType), intent(out) :: sum
        print *, "Calling real_add_subrout"
        sum%r = this%r + r
        sum%i = this%i + i
    end subroutine

end module

program generic_name_01
    use Complex_module, only: ComplexType
    implicit none
    real :: fpone, fptwo, fpzero, negfpone
    integer :: ione, izero
    type(ComplexType) :: a, c
    fpone = 1.0
    fptwo = 2.0
    fpzero = 0.0
    ione = 1
    izero = 0
    negfpone = -1.0
    c = ComplexType(fpone, fptwo)
    call c%add(ione, izero, a)
    print *, a%r, a%i
    call c%add(fpzero, negfpone, a)
    print *, a%r, a%i
end program


!================================================
        program pi_spigot_unbounded
!================================================
          do
            call print_next_pi_digit()
          end do

        contains

!------------------------------------------------
          subroutine print_next_pi_digit()
!------------------------------------------------
            use fmzm
            type (im) :: q, r, t, k, n, l, nr
            logical   :: dot=.false., init=.false.
            save      :: q, r, t, k, n, l
            if (.not.init) then
              q=to_im(1)
              r=to_im(0)
              t=to_im(1)
              k=to_im(1)
              n=to_im(3)
              l=to_im(3)
              init=.true.
            end if
            if (4*q+r-t < n*t) then
              write(6,fmt='(i1)',advance='no') to_int(n)
              if (.not.dot) then
                write(6,fmt='(a1)',advance='no') '.'
                dot=.true.
              end if
              flush(6)
              nr = 10 * (        r      - n*t )
              n  = 10 * ( (3*q + r) / t - n   )
              q  = 10 *      q
              r  = nr
            else
              nr = (2*q + r) * l
              n  = ( (q * (7*k + 2) + r*l) / (t*l) )
              q  = q * k
              t  = t * l
              l  = l + 2
              k  = k + 1
              r  = nr
            end if
          end subroutine

        end program


 SUBROUTINE ud_sh2_out(eps,est,vars,nvarn,nlayr,props,gstr,gausv,thick)
 ! routine to supply internal variables for post-process
 IMPLICIT NONE  !advisable
 INTEGER (kind=4), INTENT(IN) :: nvarn, & !number of post-process variables
                                 nlayr    !number of layers in the section
 REAL (kind=8), INTENT(OUT) :: eps(2),  & !scalar (+) measure of plastic strain
                               est(2),  & !scalar (+) measure or stress state
                               vars(:)    !special post-process variables
 REAL (kind=8), INTENT(IN) :: props(:),  & !user defined array of properties
                              gstr(3,2), & !forces and moments
                              gausv(:,:),& !(nvare,nlayr) internal variables in each layer
                              thick        !actual thickness

 REAL (kind=8) :: sxx,syy,sxy,f

 ! standard values
 ! equivalent plastic strain at bottom ant top points
 eps(1) = gausv(4,1)
 eps(2) = gausv(4,nlayr)
 ! von Mises stress at bottom ant top points
 f= -6d0/thick**2             !factor to compute top/bottom stresses
 sxx = gstr(1,1)/thick + gstr(1,2)*f    !Stress XX
 syy = gstr(2,1)/thick + gstr(2,2)*f    !!Stress YY
 sxy = gstr(3,1)/thick + gstr(3,2)*f    !!Stress XY
 est(1) = SQRT(sxx**2+syy**2-sxx*syy+3d0*sxy**2)  !Von Mises stress
 f = -f                      !change sign to factor
 sxx = gstr(1,1)/thick + gstr(1,2)*f    !Stress XX
 syy = gstr(2,1)/thick + gstr(2,2)*f    !!Stress YY
 sxy = gstr(3,1)/thick + gstr(3,2)*f    !!Stress XY
 est(2) = SQRT(sxx**2+syy**2-sxx*syy+3d0*sxy**2)  !Von Mises stress
 ! plastic strains at botton and top layers
 vars(1) = SUM(gausv(4,:))/nlayr
 vars(2:4) = gausv(1:3,1)
 vars(4) = vars(4)/2
 vars(5:7) = gausv(1:3,nlayr)
 vars(7) = vars(7)/2
 RETURN
 END SUBROUTINE ud_sh2_out


      SUBROUTINE TG01QD( DICO, STDOM, JOBFI, N, M, P, ALPHA, A, LDA,
     $                   E, LDE, B, LDB, C, LDC, N1, N2, N3, ND, NIBLCK,
     $                   IBLCK, Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA,
     $                   TOL, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute orthogonal transformation matrices Q and Z which
C     reduce the regular pole pencil A-lambda*E of the descriptor system
C     (A-lambda*E,B,C) to the generalized real Schur form with ordered
C     generalized eigenvalues. The pair (A,E) is reduced to the form
C
C                ( A1  *   *  )             ( E1  *   *  )
C       Q'*A*Z = ( 0   A2  *  ) ,  Q'*E*Z = ( 0   E2  *  ) ,         (1)
C                ( 0   0   A3 )             ( 0   0   E2 )
C
C     where the subpencils Ak-lambda*Ek, for k = 1, 2, 3, contain the
C     generalized eigenvalues which belong to certain domains of
C     interest.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the descriptor system as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     STDOM   CHARACTER*1
C             Specifies the type of the domain of interest for the
C             generalized eigenvalues, as follows:
C             = 'S':  stability type domain (i.e., left part of complex
C                     plane or inside of a circle);
C             = 'U':  instability type domain (i.e., right part of complex
C                     plane or outside of a circle);
C             = 'N':  whole complex domain, excepting infinity.
C
C     JOBFI   CHARACTER*1
C             Specifies the type of generalized eigenvalues in the
C             leading diagonal block(s) as follows:
C             = 'F':  finite generalized eigenvalues are in the
C                     leading diagonal blocks (Af,Ef), and the resulting
C                     transformed pair has the form
C
C                              ( Af  *  )             ( Ef  *  )
C                     Q'*A*Z = (        ) ,  Q'*E*Z = (        ) ;
C                              ( 0   Ai )             ( 0   Ei )
C
C             = 'I':  infinite generalized eigenvalues are in the
C                     leading diagonal blocks (Ai,Ei), and the resulting
C                     transformed pair has the form
C
C                              ( Ai  *  )             ( Ei  *  )
C                     Q'*A*Z = (        ) ,  Q'*E*Z = (        ) .
C                              ( 0   Af )             ( 0   Ef )
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of rows of the matrix B, the number of columns
C             of the matrix C and the order of the square matrices A
C             and E.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of the matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The number of rows of the matrix C.  P >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The boundary of the domain of interest for the finite
C             generalized eigenvalues of the pair (A,E). For a
C             continuous-time system (DICO = 'C'), ALPHA is the boundary
C             value for the real parts of the generalized eigenvalues,
C             while for a discrete-time system (DICO = 'D'), ALPHA >= 0
C             represents the boundary value for the moduli of the
C             generalized eigenvalues.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the state dynamics matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the matrix Q'*A*Z in real Schur form, with the elements
C             below the first subdiagonal set to zero.
C             If JOBFI = 'I', the N1-by-N1 pair (A1,E1) contains the
C             infinite spectrum, the N2-by-N2 pair (A2,E2) contains the
C             finite spectrum in the domain of interest, and the
C             N3-by-N3 pair (A3,E3) contains the finite spectrum ouside
C             of the domain of interest.
C             If JOBFI = 'F', the N1-by-N1 pair (A1,E1) contains the
C             finite spectrum in the domain of interest, the N2-by-N2
C             pair (A2,E2) contains the finite spectrum ouside of the
C             domain of interest, and the N3-by-N3 pair (A3,E3) contains
C             the infinite spectrum.
C             Ai has a block structure as in (2), where A0,0 is ND-by-ND
C             and Ai,i is IBLCK(i)-by-IBLCK(i), for i = 1, ..., NIBLCK.
C             The domain of interest for the pair (Af,Ef), containing
C             the finite generalized eigenvalues, is defined by the
C             parameters ALPHA, DICO and STDOM as follows:
C               For DICO = 'C':
C                  Real(eig(Af,Ef)) < ALPHA if STDOM = 'S';
C                  Real(eig(Af,Ef)) > ALPHA if STDOM = 'U'.
C               For DICO = 'D':
C                  Abs(eig(Af,Ef))  < ALPHA if STDOM = 'S';
C                  Abs(eig(Af,Ef))  > ALPHA if STDOM = 'U'.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N part of this array must
C             contain the descriptor matrix E.
C             On exit, the leading N-by-N part of this array contains
C             the matrix Q'*E*Z in upper triangular form, with the
C             elements below the diagonal set to zero. Its structure
C             corresponds to the block structure of the matrix Q'*A*Z
C             (see description of A).
C
C     LDE     INTEGER
C             The leading dimension of the array E.  LDE >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the input matrix B.
C             On exit, the leading N-by-M part of this array contains
C             the transformed input matrix Q'*B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed output matrix C*Z.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1,P).
C
C     N1      (output) INTEGER
C     N2      (output) INTEGER
C     N3      (output) INTEGER
C             The number of the generalized eigenvalues of the pairs
C             (A1,E1), (A2,E2) and (A3,E3), respectively.
C
C     ND      (output) INTEGER.
C             The number of non-dynamic infinite eigenvalues of the
C             pair (A,E). Note: N-ND is the rank of the matrix E.
C
C     NIBLCK  (output) INTEGER
C             If ND > 0, the number of infinite blocks minus one.
C             If ND = 0, then NIBLCK = 0.
C
C     IBLCK   (output) INTEGER array, dimension (N)
C             IBLCK(i) contains the dimension of the i-th block in the
C             staircase form (2), where i = 1,2,...,NIBLCK.
C
C     Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
C             The leading N-by-N part of this array contains the
C             orthogonal matrix Q, where Q' is the product of orthogonal
C             transformations applied to A, E, and B on the left.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.  LDQ >= MAX(1,N).
C
C     Z       (output) DOUBLE PRECISION array, dimension (LDZ,N)
C             The leading N-by-N part of this array contains the
C             orthogonal matrix Z, which is the product of orthogonal
C             transformations applied to A, E, and C on the right.
C
C     LDZ     INTEGER
C             The leading dimension of the array Z.  LDZ >= MAX(1,N).
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
C     BETA    (output) DOUBLE PRECISION array, dimension (N)
C             On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j = 1, ..., N,
C             are the generalized eigenvalues.
C             ALPHAR(j) + ALPHAI(j)*i, and BETA(j), j = 1, ..., N, are
C             the diagonals of the complex Schur form (S,T) that would
C             result if the 2-by-2 diagonal blocks of the real Schur
C             form of (A,E) were further reduced to triangular form
C             using 2-by-2 complex unitary transformations.
C             If ALPHAI(j) is zero, then the j-th eigenvalue is real;
C             if positive, then the j-th and (j+1)-st eigenvalues are a
C             complex conjugate pair, with ALPHAI(j+1) negative.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             A tolerance used in rank decisions to determine the
C             effective rank, which is defined as the order of the
C             largest leading (or trailing) triangular submatrix in the
C             QR factorization with column pivoting whose estimated
C             condition number is less than 1/TOL.  If the user sets
C             TOL <= 0, then an implicitly computed, default tolerance
C             TOLDEF = N**2*EPS,  is used instead, where EPS is the
C             machine precision (see LAPACK Library routine DLAMCH).
C             TOL < 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= 1, and if N = 0,
C             LDWORK >= 4*N,    if STDOM = 'N';
C             LDWORK >= 4*N+16, if STDOM = 'S' or 'U'.
C             For optimum performance LDWORK should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message related to LDWORK is issued by
C             XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the pencil A-lambda*E is not regular;
C             = 2:  the QZ algorithm failed to compute all generalized
C                   eigenvalues of the pair (A,E);
C             = 3:  a failure occured during the ordering of the
C                   generalized real Schur form of the pair (A,E).
C
C     METHOD
C
C     The separation of the finite and infinite parts is based on the
C     reduction algorithm of [1].
C     If JOBFI = 'F', the matrices of the pair (Ai,Ei), containing the
C     infinite generalized eigenvalues, have the form
C
C           ( A0,0  A0,k ... A0,1 )         ( 0  E0,k ... E0,1 )
C      Ai = (  0    Ak,k ... Ak,1 ) ,  Ei = ( 0   0   ... Ek,1 ) ;   (2)
C           (  :     :    .    :  )         ( :   :    .    :  )
C           (  0     0   ... A1,1 )         ( 0   0   ...   0  )
C
C     if JOBFI = 'I', the matrices Ai and Ei have the form
C
C           ( A1,1 ... A1,k  A1,0 )         ( 0 ... E1,k  E1,0 )
C      Ai = (  :    .    :    :   ) ,  Ei = ( :  .    :    :   ) ,   (3)
C           (  :   ... Ak,k  Ak,0 )         ( : ...   0   Ek,0 )
C           (  0   ...   0   A0,0 )         ( 0 ...   0     0  )
C
C     where Ai,i , for i = 0, 1, ..., k, are nonsingular upper
C     triangular matrices, and A0,0 corresponds to the non-dynamic
C     infinite modes of the system.
C
C     REFERENCES
C
C     [1] Misra, P., Van Dooren, P., and Varga, A.
C         Computation of structural invariants of generalized
C         state-space systems.
C         Automatica, 30, pp. 1921-1936, 1994.
C
C     NUMERICAL ASPECTS
C                                     3
C     The algorithm requires about 25N  floating point operations.
C
C     FURTHER COMMENTS
C
C     The number of infinite poles is computed as
C
C                   NIBLCK
C        NINFP =     Sum  IBLCK(i) = N - ND - NF,
C                    i=1
C
C     where NF is the number of finite generalized eigenvalues.
C     The multiplicities of infinite poles can be computed as follows:
C     there are IBLCK(k)-IBLCK(k+1) infinite poles of multiplicity k,
C     for k = 1, ..., NIBLCK, where IBLCK(NIBLCK+1) = 0.
C     Note that each infinite pole of multiplicity k corresponds to an
C     infinite eigenvalue of multiplicity k+1.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen, October 2002.
C     Based on the RASP routine SRSFOD.
C
C     REVISIONS
C
C     V. Sima, Dec. 2016, June 2017.
C
C     KEYWORDS
C
C     Deflating subspace, orthogonal transformation,
C     generalized real Schur form, equivalence transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER        DICO, JOBFI, STDOM
      INTEGER          INFO, LDA, LDB, LDC, LDE, LDQ, LDWORK, LDZ, M, N,
     $                 N1, N2, N3, ND, NIBLCK, P
      DOUBLE PRECISION ALPHA, TOL
C     .. Array Arguments ..
      INTEGER          IBLCK( * ), IWORK(*)
      DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*),
     $                 BETA(*), C(LDC,*), DWORK(*), E(LDE,*), Q(LDQ,*),
     $                 Z(LDZ,*)
C     .. Local Scalars ..
      LOGICAL          DISCR, LQUERY, ORDER, REDIF, STAB
      INTEGER          I, LW, MINWRK, NB, NBC, NC, NDIM, NF, NI, NLOW,
     $                 NR, NSUP, WRKOPT
C     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
C     .. External Subroutines ..
      EXTERNAL         DGEMM, DGEQRF, DLACPY, MB03QG, MB03QV, TG01MD,
     $                 XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC        INT, MAX, MIN
C
C     .. Executable Statements ..
C
      INFO  = 0
      DISCR = LSAME( DICO,  'D' )
      REDIF = LSAME( JOBFI, 'I' )
      STAB  = LSAME( STDOM, 'S' )
      ORDER = STAB .OR. LSAME( STDOM, 'U' )
C
C     Check input scalar arguments.
C
      IF(      .NOT.DISCR .AND. .NOT.LSAME( DICO,  'C' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.ORDER .AND. .NOT.LSAME( STDOM, 'N' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.REDIF .AND. .NOT.LSAME( JOBFI, 'F' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( M.LT.0 ) THEN
         INFO = -5
      ELSE IF( P.LT.0 ) THEN
         INFO = -6
      ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN
         INFO = -7
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -13
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -15
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -23
      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -25
      ELSE IF( TOL.GE.ONE ) THEN
         INFO = -29
      ELSE
         IF( N.EQ.0 ) THEN
            MINWRK = 1
         ELSE IF( ORDER ) THEN
            MINWRK = 4*N + 16
         ELSE
            MINWRK = 4*N
         END IF
         LQUERY = LDWORK.EQ.-1
C
C        Estimate the optimal block size.
C
         CALL DGEQRF( N, MAX( M, P ), A, LDA, DWORK, DWORK, -1, INFO )
         NB = INT( DWORK(1) )/MAX( 1, M, P )
         LW = MIN( NB*NB, N*MAX( M, P ) )
C
         IF( LQUERY ) THEN
            CALL TG01MD( JOBFI, N, 0, 0, A, LDA, E, LDE, B, LDB, C, LDC,
     $                   ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, NF, ND,
     $                   NIBLCK, IBLCK, TOL, IWORK, DWORK, -1, INFO )
            WRKOPT = MAX( MINWRK, LW, INT( DWORK(1) ) )
            IF( ORDER ) THEN
               NLOW = 1
               NSUP = N
               CALL MB03QG( DICO, STDOM, 'Update', 'Update', N, NLOW,
     $                      NSUP, ALPHA, A, LDA, E, LDE, Q, LDQ, Z, LDZ,
     $                      NDIM, DWORK, -1, INFO )
               WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
            END IF
         ELSE IF( LDWORK.LT.MINWRK ) THEN
            INFO = -32
         END IF
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TG01QD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         N1 = 0
         N2 = 0
         N3 = 0
         ND = 0
         NIBLCK   = 0
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Finite-infinite separation in generalized real Schur form.
C
C     Workspace:  need   4*N;
C                 prefer larger.
C
      CALL TG01MD( JOBFI, N, 0, 0, A, LDA, E, LDE, B, LDB, C, LDC,
     $             ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, NF, ND, NIBLCK,
     $             IBLCK, TOL, IWORK, DWORK, LDWORK, INFO )
C
      IF( INFO.NE.0 )
     $   RETURN
C
      WRKOPT = MAX( MINWRK, INT( DWORK(1) ) )
C
      NI = N - NF
      IF( ORDER ) THEN
         IF( REDIF ) THEN
            NLOW = NI + 1
            NSUP = N
         ELSE
            NLOW = 1
            NSUP = MAX( 1, NF )
         END IF
C
C        Separate the spectrum of (A,E). The leading NDIM-by-NDIM subpencil
C        of Af-lambda*Ef corresponds to the generalized eigenvalues in the
C        domain of interest.
C
C        Workspace:  need   4*N+16.
C
         CALL MB03QG( DICO, STDOM, 'Update', 'Update', N, NLOW, NSUP,
     $                ALPHA, A, LDA, E, LDE, Q, LDQ, Z, LDZ, NDIM,
     $                DWORK, LDWORK, INFO )
         IF( INFO.NE.0 ) THEN
            INFO = 3
            RETURN
         END IF
C
         WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
C
         IF( REDIF ) THEN
            N1 = NI
            N2 = NDIM
            N3 = N - N1 - N2
         ELSE
            N1 = NDIM
            N3 = NI
            N2 = N - N1 - N3
         END IF
C
C        Compute the generalized eigenvalues.
C
         CALL MB03QV( N, A, LDA, E, LDE, ALPHAR, ALPHAI, BETA, INFO )
      ELSE
         IF( REDIF ) THEN
            N1 = NI
            N3 = NF
         ELSE
            N1 = NF
            N3 = NI
         END IF
         N2 = 0
      END IF
C
C     Apply the transformation: B <-- Q'*B.
C
      NBC = MAX( 1, MIN( LDWORK/N, M ) )
      DO 10 I = 1, M, NBC
         NC = MIN( NBC, M-I+1 )
         CALL DGEMM( 'Transpose', 'No transpose', N, NC, N, ONE, Q, LDQ,
     $               B(1,I), LDB, ZERO, DWORK, N )
         CALL DLACPY( 'All', N, NC, DWORK, N, B(1,I), LDB )
   10 CONTINUE
C
C     Apply the transformation: C <-- C*Z.
C
      NBC = MAX( 1, MIN( LDWORK/N, P ) )
      DO 20 I = 1, P, NBC
         NR = MIN( NBC, P-I+1 )
         CALL DGEMM( 'No Transpose', 'No transpose', NR, N, N, ONE,
     $              C(I,1), LDC, Z, LDZ, ZERO, DWORK, NR )
         CALL DLACPY( 'All', NR, N, DWORK, NR, C(I,1), LDC )
   20 CONTINUE
C
      DWORK( 1 ) = MAX( WRKOPT, LW )
C
      RETURN
C *** Last line of TG01QD ***
      END


program pick_random
  implicit none

  integer :: i
  integer :: a(10) = (/ (i, i = 1, 10) /)
  real :: r

  call random_seed
  call random_number(r)
  write(*,*) a(int(r*size(a)) + 1)
end program


program energy
  real, parameter :: mass = 3.00, gravity = 0.81, height = 4.20
  real :: potential_energy

  potential_energy = mass * gravity * height
end program energy


	FUNCTION PR_WVSW  ( dosw, posw, hosw )
C************************************************************************
C* PR_WVSW								*
C*									*
C* This function computes WVSW, the combined swell wave direction in    *
C* tens of degrees, the swell wave period in seconds, and the swell     *
C* wave height in half meters, from DOSW, POSW, and HOSW.               *
C* The following equation is used:                                      *
C*									*
C*       WVSW = ( DOSW / 10 ) * 10000 + PR_WVPH ( POSW, 2 * HOSW, 0 )   *
C*									*
C* REAL PR_WVSW  ( DOSW, POSW, HOSW )                                   *
C*									*
C* Input parameters:							*
C*	DOSW		REAL	Swell wave direction in degrees         *
C*	POSW		REAL	Swell wave period in seconds            *
C*	HOSW 		REAL	Swell wave height in meters             *
C*									*
C* Output parameters:							*
C*	PR_WVSW		REAL	Combined direction, period and height   *
C**									*
C* Log:									*
C* D. Kidwell/NCEP	 2/99	                                        *
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
	PR_WVSW = RMISSD
C
	IF ( ( .not. ERMISS ( dosw ) ) .and.
     +       ( .not. ERMISS ( posw ) ) .and.
     +       ( .not. ERMISS ( hosw ) ) ) THEN
	    pphh = PR_WVPH ( posw, 2. * hosw, 0. )
	    IF ( .not. ERMISS ( pphh ) ) THEN
	        PR_WVSW = NINT ( dosw / 10. ) * 10000 + NINT ( pphh )
	    END IF
	END IF
C*
	RETURN
	END


*
*   This code comes from the NSWC fortran library with slight
*   modifications from Bruno Pincon
*
      SUBROUTINE SPFIT (X, Y, WGT, M, BREAK, L, Z, A, WK, IERR)
      implicit none
      integer M, L, IERR
      DOUBLE PRECISION X(M), Y(M), WGT(M), BREAK(L)
      DOUBLE PRECISION Z(*), A(*), WK(*)
C-----------------------------------------------------------------------
C            WEIGHTED LEAST SQUARES CUBIC SPLINE FITTING
C-----------------------------------------------------------------------
      integer N, J, K, LA, LW, LQ, LM1
      DOUBLE PRECISION TEMP(20), DX, B, C
C---------------------
      N = L + 2
C
C                DEFINE THE KNOTS FOR THE B-SPLINES
C
      WK(1) = BREAK(1)
      WK(2) = BREAK(1)
      WK(3) = BREAK(1)
      WK(4) = BREAK(1)
      do J = 2,L               ! the conditions break(k) < break(k+1) are
         WK(J + 3) = BREAK(J)  ! verified in the interface
      enddo
      WK(L + 4) = BREAK(L)
      WK(L + 5) = BREAK(L)
      WK(L + 6) = BREAK(L)
C
C     OBTAIN THE B-SPLINE COEFFICIENTS OF THE LEAST SQUARES FIT
C
      LA = N + 5     ! start indices (in wk) for the others working area
      LW = LA + N    !
      LQ = LW + N    !
      CALL BSLSQ (X, Y, WGT, M, WK(1), N, 4, WK(LA),
     *            WK(LW), WK(LQ), IERR)
*
*     pour BSLSQ : IERR =-1  not enought points for the fit
*                  IERR = 0  OK
*                  IERR = 1  non uniqness of the solution (but a solution is computed)
*
      IF (IERR .GE. 0) then
C         OBTAIN THE COEFFICIENTS OF THE FIT IN TAYLOR SERIES FORM
         CALL BSPP (WK(1), WK(LA), N, 4, BREAK,
     *              WK(LQ), LM1, TEMP)
         K = LQ
         DO J = 1,LM1
            Z(J) = WK(K)
            A(J) = WK(K + 1)
            K = K + 4
         enddo

         ! a trick to get the spline value (Z(L)) and first derivative
         ! (A(L)) on the last breakpoint : the last polynomial piece
         ! has the form  Z(LM1) + A(LM1)(x- break(l-1)) + B(LM1)(...)
         DX = BREAK(L) - BREAK(L-1)
         B = WK(LQ + 4*(L-2) + 2)
         C = WK(LQ + 4*(L-2) + 3)
         Z(L) = Z(LM1) + DX*(A(LM1) + DX*(B + DX*C))
         A(L) = A(LM1) + DX*( 2.d0*B + DX*3.d0*C)
      endif
      END

      SUBROUTINE BSLSQ (TAU, GTAU, WGT, NTAU, T, N, K, A, WK, Q, IERR)
      implicit none
      integer NTAU, K, N, IERR
      DOUBLE PRECISION TAU(NTAU), GTAU(NTAU), WGT(NTAU)
      DOUBLE PRECISION T(*), A(N), WK(N), Q(K,N)
C-----------------------------------------------------------------------
C
C        BSLSQ PRODUCES THE B-SPLINE COEFFICIENTS OF A PIECEWISE
C              POLYNOMIAL P(X) OF ORDER K WHICH MINIMIZES
C
C                SUM (WGT(J)*(P(TAU(J)) - GTAU(J))**2).
C
C
C     INPUT ...
C
C       TAU   ARRAY OF LENGTH NTAU CONTAINING DATA POINT ABSCISSAE.
C       GTAU  ARRAY OF LENGTH NTAU CONTAINING DATA POINT ORDINATES.
C       WGT   ARRAY OF LENGTH NTAU CONTAINING THE WEIGHTS.
C       NTAU  NUMBER OF DATA POINTS TO BE FITTED.
C       T     KNOT SEQUENCE OF LENGTH N + K.
C       N     DIMENSION OF THE PIECEWISE POLYNOMIAL SPACE.
C       K     ORDER OF THE B-SPLINES.
C
C     OUTPUT ...
C
C       A     ARRAY OF LENGTH N CONTAINING THE B-SPLINE COEFFICIENTS
C             OF THE L2 APPROXIMATION.
C
C       IERR  INTEGER REPORTING THE STATUS OF THE RESULTS ...
C
C             0  THE COEFFICIENT MATRIX IS NONSIGULAR. THE
C                UNIQUE LEAST SQUARES SOLUTION WAS OBTAINED.
C             1  THE COEFFICIENT MATRIX IS SINGULAR. A
C                LEAST SQUARES SOLUTION WAS OBTAINED.
C            -1  INPUT ERRORS WERE DETECTED.
C
C-----------------------------------------------------------------------
C
      integer I, J, JJ, L, LEFT, LEFTMK, MM, ntau_count
      double precision dw
      external isearch
      integer  isearch

*  some modifs :
*    1/ to avoid the sort on the datas points use a dicho search to get
*       the interval LEFT
*    2/ all the datas points outside the interval definition of the spline
*       ([T(K),T(N+1)]) or with a non positive weight are not taken into acount
*       in the fit
*
*
*   Note: the breakpoints goes to T(K) until T(N+1)  (N+1-K+1 points)
*       T(K) is the first break point  (T(K) = X(1), ..., T(I) = X(I-K+1)
*       T(N+1) = T(L+K-1) = X(L)  is the last break point
C
      do J = 1,N
         A(J) = 0.D0
         do  I = 1,K
            Q(I,J) = 0.d0
         enddo
      enddo
C
      ntau_count = 0
      LEFT = K
      DO  L = 1,NTAU
         if (      TAU(L).ge.T(K) .and. TAU(L).le.T(N+1)    ! added by Bruno
     $       .and. WGT(L) .gt. 0.d0 ) then
            ntau_count = ntau_count + 1
*           find the index left such that  T(LEFT) <= TAU(L) <= T(LEFT+1) (modified by Bruno)
            LEFT = isearch(TAU(L), T(K), N-K+2) + 3
            JJ = 0
            CALL BSPVB (T, K, K, JJ, TAU(L), LEFT, WK)

            LEFTMK = LEFT - K
            DO MM = 1,K
               DW = WK(MM)*WGT(L)
               J = LEFTMK + MM
               A(J) = DW*GTAU(L) + A(J)
               I = 1
               DO JJ = MM,K
                  Q(I,J) = WK(JJ)*DW + Q(I,J)
                  I = I + 1
               enddo
            enddo
         endif
      enddo

      IF (ntau_count .ge. MAX(2,K)) then
C        SOLVE THE NORMAL EQUATIONS
         CALL BCHFAC (Q, K, N, WK, IERR)
         CALL BCHSLV (Q, K, N, A)
      else
         ierr = -1
      endif
      end

      SUBROUTINE BCHFAC (W, NB, N, DIAG, IFLAG)
      implicit none
      integer NB, N, IFLAG
      DOUBLE PRECISION W(NB,N), DIAG(N)

C-----------------------------------------------------------------------
C  FROM  * A PRACTICAL GUIDE TO SPLINES *  BY C. DE BOOR
C  CONSTRUCTS CHOLESKY FACTORIZATION
C                     C  =  L * D * L-TRANSPOSE
C  WITH L UNIT LOWER TRIANGULAR AND D DIAGONAL, FOR GIVEN MATRIX C OF
C  ORDER  N , IN CASE  C  IS (SYMMETRIC) POSITIVE SEMIDEFINITE
C  AND BANDED, HAVING NB DIAGONALS AT AND BELOW THE MAIN DIAGONAL.
C
C******  INPUT  ******
C
C     N      THE ORDER OF THE MATRIX C.
C
C     NB     THE BANDWIDTH OF C, I.E.,
C               C(I,J) = 0 FOR ABS(I-J) .GT. NB .
C
C     W      WORK ARRAY OF SIZE NB BY N CONTAINING THE NB DIAGONALS
C            IN ITS ROWS, WITH THE MAIN DIAGONAL IN ROW 1. PRECISELY,
C            W(I,J)  CONTAINS  C(I+J-1,J), I=1,...,NB, J=1,...,N.
C            FOR EXAMPLE, THE INTERESTING ENTRIES OF A SEVEN DIAGONAL
C            SYMMETRIC MATRIX C OF ORDER 9 WOULD BE STORED IN W AS
C
C                       11 22 33 44 55 66 77 88 99
C                       21 32 43 54 65 76 87 98
C                       31 42 53 64 75 86 97
C                       41 52 63 74 85 96
C
C            ALL OTHER ENTRIES OF W NOT IDENTIFIED WITH AN ENTRY OF C
C            ARE NEVER REFERENCED.
C
C     DIAG   WORK ARRAY OF LENGTH N.
C
C******  O U T P U T  ******
C                                                         T
C     W      CONTAINS THE CHOLESKY FACTORIZATION C = L*D*L   WHERE
C            W(1,I) = 1/D(I,I) AND W(I,J) = L(I-1+J,J) (I=2,...,NB).
C
C     IFLAG  0 IF C IS NONSINGULAR AND 1 IF C IS SINGULAR.
C
C******  M E T H O D  ******
C
C   GAUSS ELIMINATION, ADAPTED TO THE SYMMETRY AND BANDEDNESS OF  C , IS
C   USED .
C     NEAR ZERO PIVOTS ARE HANDLED IN A SPECIAL WAY. THE DIAGONAL ELE-
C  MENT C(K,K) = W(1,K) IS SAVED INITIALLY IN  DIAG(K), ALL K. AT THE K-
C  TH ELIMINATION STEP, THE CURRENT PIVOT ELEMENT, VIZ.  W(1,K), IS COM-
C  PARED WITH ITS ORIGINAL VALUE, DIAG(K). IF, AS THE RESULT OF PRIOR
C  ELIMINATION STEPS, THIS ELEMENT HAS BEEN REDUCED BY ABOUT A WORD
C  LENGTH, (I.E., IF W(1,K)+DIAG(K) .LE. DIAG(K)), THEN THE PIVOT IS DE-
C  CLARED TO BE ZERO, AND THE ENTIRE K-TH ROW IS DECLARED TO BE LINEARLY
C  DEPENDENT ON THE PRECEDING ROWS. THIS HAS THE EFFECT OF PRODUCING
C   X(K) = 0  WHEN SOLVING  C*X = B  FOR  X, REGARDLESS OF  B. JUSTIFIC-
C  ATION FOR THIS IS AS FOLLOWS. IN CONTEMPLATED APPLICATIONS OF THIS
C  PROGRAM, THE GIVEN EQUATIONS ARE THE NORMAL EQUATIONS FOR SOME LEAST-
C  SQUARES APPROXIMATION PROBLEM, DIAG(K) = C(K,K) GIVES THE NORM-SQUARE
C  OF THE K-TH BASIS FUNCTION, AND, AT THIS POINT,  W(1,K)  CONTAINS THE
C  NORM-SQUARE OF THE ERROR IN THE LEAST-SQUARES APPROXIMATION TO THE K-
C  TH BASIS FUNCTION BY LINEAR COMBINATIONS OF THE FIRST K-1 . HAVING
C  W(1,K)+DIAG(K) .LE. DIAG(K) SIGNIFIES THAT THE K-TH FUNCTION IS LIN-
C  EARLY DEPENDENT TO MACHINE ACCURACY ON THE FIRST K-1 FUNCTIONS, THERE
C  FORE CAN SAFELY BE LEFT OUT FROM THE BASIS OF APPROXIMATING FUNCTIONS
C     THE SOLUTION OF A LINEAR SYSTEM
C                       C*X = B
C   IS EFFECTED BY THE SUCCESSION OF THE FOLLOWING  T W O  CALLS ...
C     CALL BCHFAC (W, NB, N, DIAG, IFLAG)   , TO GET FACTORIZATION
C     CALL BCHSLV (W, NB, N, B, X )            , TO SOLVE FOR X.
C-----------------------------------------------------------------------
C
      integer I, J, K, IMAX, JMAX, KPI, IPJ
      double precision T, RATIO

      IF (N .GT. 1) GO TO 10
         IFLAG = 1
         IF (W(1,1) .EQ. 0.D0) RETURN
         IFLAG = 0
         W(1,1) = 1.D0/W(1,1)
         RETURN
C
C     STORE THE DIAGONAL OF C IN DIAG
C
   10 DO 11 K = 1,N
         DIAG(K) = W(1,K)
   11 CONTINUE
C
C     FACTORIZATION
C
      IFLAG = 0
      DO 60 K = 1,N
         T = W(1,K) + DIAG(K)
         IF (T .NE. DIAG(K)) GO TO 30
            IFLAG = 1
            DO 20 J = 1,NB
               W(J,K) = 0.D0
   20       CONTINUE
            GO TO 60
C
   30    T = 1.D0/W(1,K)
         W(1,K) = T
         IMAX = MIN(NB - 1,N - K)
         IF (IMAX .LT. 1) GO TO 60
         JMAX = IMAX
         DO 50 I = 1,IMAX
            RATIO = T*W(I+1,K)
            KPI = K + I
            DO 40 J = 1,JMAX
               IPJ = I + J
               W(J,KPI) = W(J,KPI) - W(IPJ,K)*RATIO
   40       CONTINUE
            JMAX = JMAX - 1
            W(I+1,K) = RATIO
   50    CONTINUE
   60 CONTINUE
      RETURN
      END

      SUBROUTINE BCHSLV (W, NB, N, B)
      implicit none
      integer NB, N
      DOUBLE PRECISION W(NB,N), B(N)
C-----------------------------------------------------------------------
C
C     BCHSLV SOLVES THE LINEAR SYSTEM C*X = B FOR X WHEN W CONTAINS
C     THE CHOLESKY FACTORIZATION OBTAINED BY THE SUBROUTINE BCHFAC
C     FOR THE BANDED SYMMETRIC POSITIVE DEFINITE MATRIX C.
C
C     INPUT ...
C
C        N   THE ORDER OF THE MATRIX C
C        NB  THE BANDWIDTH OF C
C        W   THE CHOLESKY FACTORIZATION OF C
C        B   VECTOR OF LENGTH N CONTAINING THE RIGHT SIDE
C
C     OUTPUT ...
C
C        B   SOLUTION X OF THE LINEAR SYSTEM C*X = B
C
C                                       T
C     NOTE.  THE FACTORIZATION C = L*D*L  IS USED, WHERE L IS A
C     UNIT LOWER TRIANGULAR MATRIX AND D A DIAGONAL MATRIX.
C
C-----------------------------------------------------------------------
C
      integer J, NBM1, K, JMAX, JPK

      IF (N .GT. 1) GO TO 10
      B(1) = B(1)*W(1,1)
      RETURN
C
C     FORWARD SUBSTITUTION. SOLVE L*Y = B FOR Y AND STORE Y IN B.
C
   10 NBM1 = NB - 1
      DO 30 K = 1,N
         JMAX = MIN(NBM1,N - K)
         IF (JMAX .LT. 1) GO TO 30
         DO 20 J = 1,JMAX
            JPK = J + K
            B(JPK) = B(JPK) - W(J + 1,K)*B(K)
   20    CONTINUE
   30 CONTINUE
C                              T     -1
C     BACKSUBSTITUTION. SOLVE L X = D  Y  FOR X AND STORE X IN B.
C
      K = N
   40    B(K) = B(K)*W(1,K)
         JMAX = MIN(NBM1,N - K)
         IF (JMAX .LT. 1) GO TO 60
         DO 50 J = 1,JMAX
            JPK = J + K
            B(K) = B(K) - W(J + 1,K)*B(JPK)
   50    CONTINUE
   60    K = K - 1
         IF (K .GT. 0) GO TO 40
      RETURN
      END

      SUBROUTINE BSPVB (T, K, JHIGH, J, X, LEFT, BLIST)
      implicit none
      integer K, JHIGH, J, LEFT
      DOUBLE PRECISION T(*), X, BLIST(K)
C-----------------------------------------------------------------------
C
C     BSPVB CALCULATES THE VALUE OF ALL POSSIBLY NONZERO B-SPLINES
C     AT X OF ORDER MAX(JHIGH,J + 1) WHERE T(K) .LE. X .LT. T(N+1).
C
C     DESCRIPTION OF ARGUMENTS
C
C         INPUT
C
C          T       - KNOT VECTOR OF LENGTH N + K.
C          K       - HIGHEST POSSIBLE ORDER OF THE B-SPLINES.
C          JHIGH   - ORDER OF B-SPLINES (1 .LE. JHIGH .LE. K).
C          J       - J .LE. 0  GIVES B-SPLINES OF ORDER JHIGH.
C                    J .GE. 1  ON A PREVIOUS CALL TO BSPVB THE
C                              B-SPLINES OF ORDER J WERE COM-
C                              PUTED AND STORED IN BLIST. IT IS
C                              ASSUMED THAT WORK HAS NOT BEEN
C                              MODIFIED AND THAT J .LT. K.
C          X       - ARGUMENT OF THE B-SPLINES.
C          LEFT    - LARGEST INTEGER SUCH THAT
C                    T(LEFT) .LE. X .LT. T(LEFT+1)
C
C         OUTPUT
C
C          BLIST   - VECTOR OF LENGTH K FOR SPLINE VALUES.
C          J       - B-SPLINES OF ORDER J HAVE BEEN COMPUTED
C                    AND STORED IN BLIST.
C
C-----------------------------------------------------------------------
C     WRITTEN BY CARL DE BOOR (UNIVERSITY OF WISCONSIN) AND MODIFIED
C         BY A.H. MORRIS (NSWC).
C-----------------------------------------------------------------------
C
      integer I, IMJ, L
      double precision S, TIMJ, TI, TERM

      IF (J .GT. 0) GO TO 10
         J = 1
         BLIST(1) = 1.D0
         IF (J .GE. JHIGH) RETURN
C
   10 S = 0.D0
      DO 20 L = 1,J
         I = LEFT + L
         IMJ = I - J
         TIMJ = T(IMJ)
         TI = T(I)
         TERM = BLIST(L)/(TI - TIMJ)
         BLIST(L) = S + (TI - X)*TERM
         S = (X - TIMJ)*TERM
   20 CONTINUE
      J = J + 1
      BLIST(J) = S
      IF (J .LT. JHIGH) GO TO 10
C
      RETURN
      END

      SUBROUTINE BSPP (T, A, N, K, BREAK, C, L, WK)
      implicit none
      integer N, K, L
      DOUBLE PRECISION T(*), A(N), BREAK(*), C(K,*), WK(K,*)
C-----------------------------------------------------------------------
C
C              CONVERSION FROM B-SPLINE REPRESENTATION
C              TO PIECEWISE POLYNOMIAL REPRESENTATION
C
C
C     INPUT ...
C
C       T     KNOT SEQUENCE OF LENGTH N+K
C       A     B-SPLINE COEFFICIENT SEQUENCE OF LENGTH N
C       N     LENGTH OF A
C       K     ORDER OF THE B-SPLINES
C
C     OUTPUT ...
C
C       BREAK BREAKPOINT SEQUENCE, OF LENGTH L+1, CONTAINING
C             (IN INCREASING ORDER) THE DISTINCT POINTS OF THE
C             SEQUENCE T(K),...,T(N+1).
C       C     KXL MATRIX WHERE C(I,J) = (I-1)ST RIGHT DERIVATIVE
C             OF THE PP AT BREAK(J) DIVIDED BY FACTORIAL(I-1).
C       L     NUMBER OF POLYNOMIALS WHICH FORM THE PP
C
C     WORK AREA ...
C
C       WK    2-DIMENSIONAL ARRAY OF DIMENSION (K,K+1)
C
C-----------------------------------------------------------------------
C
      integer I, J, KM1, KP1, LEFT, JJ, JP1, KMJ, IL, ILJ, ILKJ
      double precision TERM, DIFF, R, S, X

      L = 0
      BREAK(1) = T(K)
      IF (K .EQ. 1) GO TO 100
      KM1 = K - 1
      KP1 = K + 1
C
C          GENERAL K-TH ORDER CASE
C
      DO 60 LEFT = K,N
         IF (T(LEFT) .EQ. T(LEFT + 1)) GO TO 60
         L = L + 1
         BREAK(L + 1) = T(LEFT + 1)
         DO 10 J = 1,K
            JJ = LEFT - K + J
            WK(J,1) = A(JJ)
   10    CONTINUE
C
         DO 21 J = 1,KM1
            JP1 = J + 1
            KMJ = K - J
            DO 20 I = 1,KMJ
               IL = I + LEFT
               ILKJ = IL - KMJ
               DIFF = T(IL) - T(ILKJ)
               WK(I,JP1) = (WK(I+1,J) - WK(I,J))/DIFF
   20       CONTINUE
   21    CONTINUE
C
         WK(1,KP1) = 1.D0
         X = T(LEFT)
         C(K,L) = WK(1,K)
         R = 1.D0
         DO 50 J = 1,KM1
            JP1 = J + 1
            S = 0.D0
            DO 30 I = 1,J
               IL = I + LEFT
               ILJ = IL - J
               TERM = WK(I,KP1)/(T(IL) - T(ILJ))
               WK(I,KP1) = S + (T(IL) - X)*TERM
               S = (X - T(ILJ))*TERM
   30       CONTINUE
            WK(JP1,KP1) = S
C
            S = 0.D0
            KMJ = K - J
            DO 40 I = 1,JP1
               S = S + WK(I,KMJ)*WK(I,KP1)
   40       CONTINUE
            R = (R*DBLE(KMJ))/DBLE(J)
            C(KMJ,L) = R*S
   50    CONTINUE
   60 CONTINUE
      RETURN
C
C          PIECEWISE CONSTANT CASE
C
  100 DO 110 LEFT = K,N
         IF (T(LEFT) .EQ. T(LEFT + 1)) GO TO 110
         L = L + 1
         BREAK(L + 1) = T(LEFT + 1)
         C(1,L) = A(LEFT)
  110 CONTINUE
      RETURN
      END


      SUBROUTINE KTETRA (IOPT,JTYPE)
C
C     ELEMENT STIFFNESS MATRIX GENERATOR FOR THE TETRAHEDRON SOLID
C     ELEMENT
C
C     LOOKING DOWN ON THIS ELEMENT, GRIDS 1,2,3 ARE THE BASE AND MUST BE
C     LABELED COUNTERCLOCKWISE. GRID 4 MUST BE ABOVE THE PLANE FORMED BY
C     GRIDS 1,2,3 AND CLOSEST TO THIS OBSERVER.
C
C     ECPT FOR THE TETRAHEDRON SOLID ELEMENT
C     --------------------------------------
C     ECPT( 1) = ELEMENT  ID
C     ECPT( 2) = MATERIAL ID (MAT1 MATERIAL TYPE)
C     ECPT( 3) = SIL GRID POINT 1
C     ECPT( 4) = SIL GRID POINT 2
C     ECPT( 5) = SIL GRID POINT 3
C     ECPT( 6) = SIL GRID POINT 4
C     ECPT( 7) = COORD SYS ID GRID PT 1
C     ECPT( 8) = X1
C     ECPT( 9) = Y1
C     ECPT(10) = Z1
C     ECPT(11) = COORD SYS ID GRID PT 2
C     ECPT(12) = X2
C     ECPT(13) = Y2
C     ECPT(14) = Z2
C     ECPT(15) = COORD SYS ID GRID PT 3
C     ECPT(16) = X3
C     ECPT(17) = Y3
C     ECPT(18) = Z3
C     ECPT(19) = COORD SYS ID GRID PT 4
C     ECPT(20) = X4
C     ECPT(21) = Y4
C     ECPT(22) = Z4
C     ECPT(23) = ELEMENT TEMPERATURE
C
C     JTYPE = 1 FOR WEDGE, = 2 FOR HEXA1, = 3 FOR HEXA2, AND = 0 TETRA
C     IF JTYPE IS NEGATIVE, THIS IS LAST CALL FROM KSOLID
C
C
      LOGICAL         NOGO    ,HEAT      ,HYDRO
      INTEGER         OUT     ,NECPT(4)  ,DIREC    ,EL(2,4)  ,SCR4
      REAL            NU      ,MATBUF
      DOUBLE PRECISION C      ,G         ,H        ,TEMP     ,HDETER  ,
     1                TEMP1   ,T         ,CT       ,KIJ      ,GCT
      CHARACTER       UFM*23
      COMMON /XMSSG / UFM
      COMMON /BLANK / SKIP(16) ,VOLUME   ,SURFAC
      COMMON /SMA1ET/ ECPT(100)
      COMMON /SMA1DP/ C(72)    ,G(36)    ,H(16)    ,TEMP(12) ,T(9)    ,
     1                CT(18)   ,GCT(18)  ,KIJ(36)  ,HDETER   ,TEMP1   ,
     2                NGPT     ,DIREC    ,KOUNT    ,TVOL
      COMMON /SMA1HT/ HEAT
      COMMON /HYDROE/ HYDRO
      COMMON /MATIN / MATID    ,INFLAG   ,ELTEMP
      COMMON /MATOUT/ E        ,GG       ,NU       ,RHO      ,ALPHA   ,
     1                TSUB0    ,GSUBE    ,SIGT     ,SIGC     ,SIGS
      COMMON /HMTOUT/ MATBUF(7)
      COMMON /SMA1CL/ IOPT4    ,K4GGSW   ,NPVT     ,ISKP(17) ,NOGOO
      COMMON /SMA1IO/ DUM1(10) ,IFKGG    ,DUM2(1)  ,IF4GG    ,DUM3(23)
      COMMON /SYSTEM/ SYSBUF   ,OUT      ,NOGO
      EQUIVALENCE     (NECPT(1),ECPT(1))
      DATA    IDFLAG/ 0 /,    SCR4    /   304 /
      DATA    EL    / 4HCWED, 4HGE  , 4HCHEX, 4HA1  , 4HCHEX, 4HA2  ,
     1                4HCTET, 4HRA    /
C
C     FILL THE 4 X 4 H MATRIX.
C
      IF (NECPT(1) .EQ. IDFLAG) GO TO 100
      IDFLAG = NECPT(1)
      DIREC  = 0
      KOUNT  = 0
      TVOL   = 0.0
      NGPT   = 99
      IF (VOLUME.LE.0.0 .AND. SURFAC.LE.0.0) GO TO 100
      NGPT   = 8
      IF (IABS(JTYPE) .EQ. 1) NGPT = 6
      IF (JTYPE .EQ. 0) NGPT  = 4
  100 IF (JTYPE .LE. 0) KOUNT = KOUNT + 1
C
C     RETURN IF SUB-TETRA DOES NOT CONTRIBUTE TO PIVOT STIFFNESS AND NO
C     GEOMETRY TESTS ARE BEING MADE ON IT.
C
      IF (IOPT .GE. 100) GO TO 140
      DO 131 I = 3,6
      IF (NPVT .EQ. NECPT(I)) GO TO 140
  131 CONTINUE
      IF (KOUNT.EQ.NGPT .AND. JTYPE.NE.0) GO TO 910
      RETURN
C
  140 H( 1) = 1.0D0
      H( 2) = ECPT( 8)
      H( 3) = ECPT( 9)
      H( 4) = ECPT(10)
      H( 5) = 1.0D0
      H( 6) = ECPT(12)
      H( 7) = ECPT(13)
      H( 8) = ECPT(14)
      H( 9) = 1.0D0
      H(10) = ECPT(16)
      H(11) = ECPT(17)
      H(12) = ECPT(18)
      H(13) = 1.0D0
      H(14) = ECPT(20)
      H(15) = ECPT(21)
      H(16) = ECPT(22)
C
C     INVERT H AND GET THE DETERMINANT
C
      ISING = 0
      CALL INVERD (4,H(1),4,DUM,0,HDETER,ISING,TEMP(1))
C
C     IF THE DETERMINANT IS .LE. 0 THE TETRAHEDRON HAS BAD OR REVERSE
C     GEOMETRY WHICH IS AN ERROR CONDITION.
C
      IF (ISING .EQ.  2) GO TO 149
      IF (IOPT .LT. 100) GO TO 200
      IOPT = IOPT - 100
      IF (DIREC .NE.  0) GO TO 148
      DIREC = 1
      IF (HDETER .LT.0.0D0) DIREC = -1
      GO TO 200
  148 IF (DIREC.EQ. 1 .AND. HDETER.GT.0.0D0) GO TO 200
      IF (DIREC.EQ.-1 .AND. HDETER.LT.0.0D0) GO TO 200
  149 WRITE  (OUT,150) UFM,NECPT(1)
  150 FORMAT (A23,' 4004, MODULE SMA1 DETECTS BAD OR REVERSE GEOMETRY ',
     1       'FOR ELEMENT ID',I10)
      NOGOO = 1
      RETURN
C
C     SKIP SUB-TETRAHEDRON IF IT DOES NOT CONTRIBUTE TO PIVOT STIFFNESS
C
  200 DO 201 I = 3,6
      IF (NPVT .EQ. NECPT(I)) GO TO 209
  201 CONTINUE
      IF (KOUNT.EQ.NGPT .AND. JTYPE.NE.0) GO TO 910
      RETURN
C
C     AT THIS POINT BRANCH ON HEAT OR STRUCTURE PROBLEM.
C
  209 HDETER = DABS(HDETER)
      IF (HEAT ) GO TO 1010
      IF (HYDRO) GO TO 1060
C
C     GET THE MATERIAL DATA AND FILL THE 6X6 G MATERIAL STRESS-STRAIN
C     MATRIX.
C
      INFLAG = 1
      MATID  = NECPT(2)
      ELTEMP = ECPT(23)
      CALL MAT (NECPT(1))
      DO 210 I = 1,36
  210 G(I)  = 0.0D0
      TEMP1 = (1.0+NU)*(1.0-2.0*NU)
      IF (DABS(TEMP1) .GT. 1.0D-6) GO TO 240
      WRITE  (OUT,230) UFM,MATID,ECPT(1)
  230 FORMAT (A23,' 4005, AN ILLEGAL VALUE OF -NU- HAS BEEN SPECIFIED ',
     1       'UNDER MATERIAL ID',I10,' FOR ELEMENT ID',I10)
      NOGOO = 1
      RETURN
C
  240 G( 1) = E*(1.0-NU)/TEMP1
      G( 8) = G(1)
      G(15) = G(1)
      G( 2) = E*NU/TEMP1
      G( 3) = G(2)
      G( 7) = G(2)
      G( 9) = G(2)
      G(13) = G(2)
      G(14) = G(2)
      G(22) = GG
      G(29) = GG
      G(36) = GG
C
C     FILL 4 C-MATRICES. (6X3) EACH.
C
      DO 400 I = 1,72
  400 C(I) = 0.0D0
      DO 500 I = 1,4
      J = 18*I - 18
      C(J+ 1) = H(I+ 4)
      C(J+ 5) = H(I+ 8)
      C(J+ 9) = H(I+12)
      C(J+11) = H(I+12)
      C(J+12) = H(I+ 8)
      C(J+13) = H(I+12)
      C(J+15) = H(I+ 4)
      C(J+16) = H(I+ 8)
      C(J+17) = H(I+ 4)
  500 CONTINUE
C
C     DIVIDE DETERMINANT BY 6.0, AND BY AN ADDITIONAL 2.0 IF A SUB-TETRA
C     FOR THE HEXA-10 ELEMENT.
C     FOR WEDGES, 1ST 6 CONFIGURATUONS ARE MULTIPLIED BY 2.
C     ALL CONFIGURATIONS ARE DIVIDED BY 6.
C
      IF (IOPT) 602,601,602
  601 HDETER = HDETER/6.0D0
      GO TO 610
  602 IF (IOPT.GE.11 .AND. IOPT.LE.22) GO TO 603
      HDETER = HDETER/12.0D0
      GO TO 610
C
C     WEDGES
C
  603 HDETER = HDETER/36.0D0
      IF (IOPT .LE. 16) HDETER = HDETER*2.0D0
  610 DO 700 I = 1,36
  700 KIJ(I) = 0.0D0
C
C     DETERMINE THE PIVOT POINT
C
      DO 720 I = 2,5
      KA = 4*I - 1
      NPOINT = 18*I - 35
      IF (NECPT(I+1) .NE. NPVT) GO TO 720
      GO TO 740
  720 CONTINUE
      CALL MESAGE (-30,34,ECPT(1))
C
C     PICK UP PIVOT TRANSFORMATION IF CSID IS NON-ZERO.
C
  740 IF (NECPT(KA)) 750,760,750
  750 CALL TRANSD (NECPT(KA),T)
      CALL GMMATD (T(1),3,3,1, C(NPOINT),6,3,1, CT(1))
      GO TO 778
C
C                     T  T
C     AT THIS POINT  T  C  IS STORED AS A 3X6 IN THE CT ARRAY.
C                     I  I
C
C                                                T T
C     NOW MULTIPLY ON THE RIGHT BY G   TO FORM  T C G   (3X6)
C                                   E            I I E
C
  760 CALL GMMATD (C(NPOINT),6,3,1, G(1),6,6,0, GCT(1))
      GO TO 781
  778 CALL GMMATD (CT(1),3,6,0, G(1),6,6,0, GCT(1))
  781 DO 790 I = 1,18
      GCT(I) = GCT(I)*HDETER
  790 CONTINUE
C
C     LOOP THROUGH THE 4 POINTS INSERTING THE STIFFNESS MATRIX FOR
C     EACH WITH RESPECT TO THE PIVOT POINT.
C
      DO 900 I = 1,4
      IF (NECPT(4*I+3)) 810,820,810
  810 CALL TRANSD (NECPT(4*I+3),T)
      CALL GMMATD (C(18*I-17),6,3,0, T(1),3,3,0, CT(1))
      CALL GMMATD (GCT(1),3,6,0, CT(1),6,3,0, T(1))
      GO TO 830
C
C     NO TRANSFORMATION
C
  820 CALL GMMATD (GCT(1),3,6,0, C(18*I-17),6,3,0, T(1))
C
C     INSERT 3X3 KIJ INTO 6X6 KIJ AND CALL SMA1B FOR INSERTION.
C
  830 KIJ( 1) = T(1)
      KIJ( 2) = T(2)
      KIJ( 3) = T(3)
      KIJ( 7) = T(4)
      KIJ( 8) = T(5)
      KIJ( 9) = T(6)
      KIJ(13) = T(7)
      KIJ(14) = T(8)
      KIJ(15) = T(9)
C
      CALL SMA1B (KIJ(1),NECPT(I+2),-1,IFKGG,0.0D0)
      TEMP1 = GSUBE
      IF (IOPT4) 840,900,840
  840 IF (GSUBE) 850,900,850
  850 CALL SMA1B (KIJ(1),NECPT(I+2),-1,IF4GG,TEMP1)
C
  900 CONTINUE
C
C     IF USER REQUESTED VOLUME AND SURFACE CALCULATIONS, WE NEED TO SAVE
C     IN SCR4 THE FOLLOWING
C     WORDS 1,2 = ELEM. BCD NAME
C             3 = ELEM. ID
C             4 = VOLUME
C             5 = MASS
C             6 = NO. OF GRID POINTS, NGPT
C           7 THRU 6+NGPT = GRID POINTS
C           7+NGPT THRU 7+5*NGPT = BGPDT DATA
C
      TVOL = TVOL + HDETER/4.0D+0
      IF (KOUNT .LT. NGPT) GO TO 950
  910 IF (JTYPE .GT. 0) GO TO 950
      ECPT(2) = TVOL*VOLUME
      IF (JTYPE.EQ.0 .AND. SURFAC.GT.0.0) GO TO 920
      J = IABS(JTYPE)
      ECPT(3) = TVOL
      IF (RHO .GT. 0.0) ECPT(3) = TVOL*RHO
      NECPT(4) = NGPT
      CALL WRITE (SCR4,EL(1,J),2,0)
      CALL WRITE (SCR4,ECPT(1),4,0)
      IF (SURFAC .LE. 0.0) GO TO 950
      J = NGPT*5
      CALL WRITE (SCR4,ECPT(53),J,1)
      GO TO 950
  920 CALL WRITE (SCR4,EL(1,4),2,0)
      CALL WRITE (SCR4,ECPT(1),2,0)
      IF (RHO .GT. 0.0) TVOL = TVOL*RHO
      ECPT (1) = TVOL
      NECPT(2) = NGPT
      CALL WRITE (SCR4,ECPT(1),22,1)
C
  950 RETURN
C
C     HEAT PROBLEM LOGIC FOR 1 PIVOT ROW OF 1 TETRAHEDRON.
C
C     OBTAIN G  MATERIAL MATRIX FROM HMAT ROUTINE
C             E
C
 1010 MATID  = NECPT(2)
      INFLAG = 3
      ELTEMP = ECPT(23)
      CALL HMAT (NECPT)
      G( 1)  = 0.0D0
      G( 2)  = 0.0D0
      G( 3)  = 0.0D0
      G( 4)  = 0.0D0
      G( 5)  = 0.0D0
      G( 6)  = MATBUF(1)
      G( 7)  = MATBUF(2)
      G( 8)  = MATBUF(3)
      G( 9)  = 0.0D0
      G(10)  = MATBUF(2)
      G(11)  = MATBUF(4)
      G(12)  = MATBUF(5)
      G(13)  = 0.0D0
      G(14)  = MATBUF(3)
      G(15)  = MATBUF(5)
      G(16)  = MATBUF(6)
C
C     OBTAIN THE FOUR CONDUCTIVITY VALUES NEEDED FOR PIVOT ROW BEING
C     INSERTED.
C
 1020 CONTINUE
      CALL GMMATD (G(1),4,4,0, H(1),4,4,0, C(5))
      IHCOL   = I - 2
      TEMP(1) = H(IHCOL  )
      TEMP(2) = H(IHCOL+4)
      TEMP(3) = H(IHCOL+8)
      TEMP(4) = H(IHCOL+12)
      CALL GMMATD (TEMP(1),1,4,0, C(5),4,4,0, C(1))
C
C     DIVIDE CONDUCTIVITY BY 2.0 IF THIS IS A SUB-TETRA OF A HEXA2
C     ELEMENT.
C
      IF (IOPT) 1045,1040,1045
 1040 HDETER = HDETER/6.0D0
      GO TO 1046
 1045 IF (IOPT.GE.11 .AND. IOPT.LE.22) GO TO 1048
      HDETER = HDETER/12.0D0
      GO TO 1046
C
C     WEDGES
C
 1048 HDETER = HDETER/36.0D0
      IF (IOPT .LE. 16) HDETER = HDETER*2.0D0
 1046 DO 1047 I = 1,4
      C(I) = C(I)*HDETER
 1047 CONTINUE
C
C     INSERT THE PIVOT ROW.
C
      DO 1050 I = 1,4
      CALL SMA1B (C(I),NECPT(I+2),NPVT,IFKGG,0.0D0)
 1050 CONTINUE
      RETURN
C
C     HYDROELASTIC PROBLEM, OBTAIN DENSITY AND RETURN
C
 1060 MATID  = NECPT(2)
      INFLAG = 11
      CALL MAT (NECPT(1))
      DO 1070 IDLH = 1,16
 1070 G(IDLH) = 0.0D0
      G(6)  = 1.0D0/DBLE(RHO)
      G(11) = G(6)
      G(16) = G(6)
      GO TO 1020
      END


SUBROUTINE banmul(kb,loads,ans)
! This subroutine multiplies a symmetrical band kb by the vector loads.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::kb(:,:),loads(0:)
 REAL(iwp),INTENT(OUT)::ans(0:)
 INTEGER::neq,nband,i,j
 REAL(iwp)::x,zero=0.0_iwp
 neq=UBOUND(kb,1)
 nband=UBOUND(kb,2)-1
 DO i=1,neq
   x=zero
   DO j=nband+1,1,-1
     IF(i+j>nband+1)x=x+kb(i,j)*loads(i+j-nband-1)
   END DO
   DO j=nband,1,-1
     IF(i-j<neq-nband)x=x+kb(i-j+nband+1,j)*loads(i-j+nband+1)
   END DO
   ans(i)=x
 END DO
RETURN
END SUBROUTINE banmul


!{\src2tex{textfont=tt}}
!!****f* ABINIT/sg_fftpad
!! NAME
!! sg_fftpad
!!
!! FUNCTION
!! Fast fourier transform.
!! This is the zero-padding version of "fft".  See fft for comments.
!!
!! COPYRIGHT
!! Copyright by Stefan Goedecker, Ithaca, NY USA, July 14, 1993
!! Copyright (C) 1998-2001 ABINIT group (DCA, XG)
!! This file is distributed under the terms of the
!! GNU General Public License, see ~ABINIT/Infos/copyright
!! or http://www.gnu.org/copyleft/gpl.txt .
!!
!! INPUTS
!!  arr(2,nd1,nd2,nd3)=input complex array with alternating real and imaginary
!!   elements; data resides in 2*n1*n2*n3 of this array, spread out.
!!  fftcache=size of the cache (kB)
!!  gbound(4*mgbound+4)=integer ranges of reciprocal space points on which data
!!   is nonzero, as needed to skip fft of arrays of 0 s
!!  mgbound=needed to dimension gbound
!!  nd1,nd2,nd3=memory dimension of arr and ftarr
!!  n1,n2,n3=physical dimension of the transform
!!  ris=(real(dp)) sign of exponential in transform
!!
!! OUTPUT
!!  ftarr(2,nd1,nd2,nd3)=working space for transform and contains output
!!
!! SIDE EFFECTS
!!
!! NOTES
!!  See fft.f
!!
!! TODO
!!
!! PARENTS
!!      fourwf
!!
!! SOURCE

 subroutine sg_fftpad(fftcache,mgbound,nd1,nd2,nd3,n1,n2,n3,&
& arr,ftarr,ris,gbound)

 use basis_defs
 implicit none

!Arguments ------------------------------------
 integer :: fftcache,mgbound,nd1,nd2,nd3,n1,n2,n3
 integer :: gbound(2*mgbound+4)
 real(dp) :: ris
 real(dp) :: arr(2,nd1,nd2,nd3),ftarr(2,nd1,nd2,nd3)

!Local variables-------------------------------
!mfac sets maximum number of factors (5, 4, 3, or 2) which may be
!contained within any n1, n2, or n3
!mg sets the maximum 1 dimensional fft length (any one of n1, n2, or n3)
!xg : the signification of mg is changed with respect to fft3dp !!!
 integer, parameter :: mfac=11,mg=2048
 integer :: i1,i2,i3,g3min,g3max,ic,index,jx,jy,jyy,jzz,jz,nd13,&
& n1i,n2i,n23,n3i,n3p
 integer :: aft(mfac),bef(mfac),ind(mg),now(mfac)
 real(dp), parameter :: tol=1.0d-12
 real(dp) :: trig(2,mg)
 character :: message*500

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

! DEBUG
!write(6,*)' sg_fftpad : enter '
!if(.true.) stop
!return
! ENDDEBUG

!Check that dimension is not exceeded
 if (n1>mg.or.n2>mg.or.n3>mg) then
  write(message, '(a,a,a,a,3i10,a,i10,a)' ) ch10,&
&  ' fft: BUG -',ch10,&
&  '  one of the dimensions n1,n2,n3=',n1,n2,n3,&
&  '  exceeds allowed dimension mg=',mg,ch10
!  call wrtout(06,message,'PERS')
!  call leave_new('PERS')
 endif

 g3min=gbound(1)
 g3max=gbound(2)

! --------------------------------------------------------------------------

 if (abs(ris-1.d0)<tol) then

! Handle G -> r  transform (G sphere to fft box)

! Transform along x direction
  call sg_ctrig(n1,trig,aft,bef,now,ris,ic,ind,mfac,mg)

! Zero out the untransformed (0) data part of the work array
! -- at every (y,z) there are 0 s to be added to the ends of
! the x data so have to zero whole thing.
  ftarr(:,:,:,:)=0.0d0

  call sg_fftpx(fftcache,mfac,mg,mgbound,nd1,nd2,nd3,n2,n3,&
&  arr,ftarr,trig,aft,now,bef,ris,ind,ic,gbound)

! Transform along y direction in two regions of z
  if (n2/=n1)then
   call sg_ctrig(n2,trig,aft,bef,now,ris,ic,ind,mfac,mg)
  endif

! First y transform: z=1..g3max+1
  n3p=g3max+1
  n1i=1 ; n3i=1
  call sg_ffty(fftcache,mfac,mg,nd1,nd2,nd3,n1i,n1,n3i,n3p,ftarr,arr,&
&  trig,aft,now,bef,ris,ind,ic)

! Zero out the untransformed (0) data part of the work array
! -- only need to zero specified ranges of z
  arr(:,:,:,n3p+1:g3min+n3)=0.0d0

! Second y transform: z=g3min+1..0 (wrapped around)
  n3p=-g3min
  if (n3p>0) then
   n3i=1+g3min+n3 ; n1i=1
   call sg_ffty(fftcache,mfac,mg,nd1,nd2,nd3,n1i,n1,n3i,n3,ftarr,arr,&
&   trig,aft,now,bef,ris,ind,ic)
  endif

! Transform along z direction
  if (n3/=n2) then
   call sg_ctrig(n3,trig,aft,bef,now,ris,ic,ind,mfac,mg)
  endif

!$OMP PARALLEL DO SHARED(aft,arr,bef,fftcache,ftarr,ind,ic)&
!$OMP&SHARED(nd1,nd2,nd3,now,n1,n2,ris,trig)&
!$OMP&PRIVATE(i2)
  do i2=1,n2
   call sg_fftz(fftcache,mfac,mg,nd1,nd2,nd3,n1,i2,i2,arr,ftarr,&
&   trig,aft,now,bef,ris,ind,ic)
  enddo
!$OMP END PARALLEL DO

 else

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

! Handle r -> G transform (from fft box to G sphere)

! Transform along z direction
  call sg_ctrig(n3,trig,aft,bef,now,ris,ic,ind,mfac,mg)

!$OMP PARALLEL DO SHARED(aft,arr,bef,fftcache,ftarr,ind,ic)&
!$OMP&SHARED(nd1,nd2,nd3,now,n1,n2,ris,trig)&
!$OMP&PRIVATE(i2)
  do i2=1,n2
   call sg_fftz(fftcache,mfac,mg,nd1,nd2,nd3,n1,i2,i2,arr,ftarr,&
&   trig,aft,now,bef,ris,ind,ic)
  enddo
!$OMP END PARALLEL DO

! Transform along y direction in two regions of z
  if (n2/=n3) then
   call sg_ctrig(n2,trig,aft,bef,now,ris,ic,ind,mfac,mg)
  endif

! First y transform: z=1..g3max+1
  n3p=g3max+1
  n1i=1 ; n3i=1
  call sg_ffty(fftcache,mfac,mg,nd1,nd2,nd3,n1i,n1,n3i,n3p,ftarr,arr,&
&  trig,aft,now,bef,ris,ind,ic)

! Second y transform: z=g3min+1..0 (wrapped around)
  n3p=-g3min
  if (n3p>0) then
   n1i=1 ; n3i=1+g3min+n3
   call sg_ffty(fftcache,mfac,mg,nd1,nd2,nd3,n1i,n1,n3i,n3,ftarr,arr,&
&   trig,aft,now,bef,ris,ind,ic)
  endif

! Transform along x direction
  if (n1/=n2) then
   call sg_ctrig(n1,trig,aft,bef,now,ris,ic,ind,mfac,mg)
  endif

! Zero out the untransformed (0) data part of the work array
! -- at every (y,z) there are 0 s to be added to the ends of
! the x data so have to zero whole thing.
 ftarr(:,:,:,:)=0.0d0

  call sg_fftpx(fftcache,mfac,mg,mgbound,nd1,nd2,nd3,n2,n3,&
&       arr,ftarr,trig,aft,now,bef,ris,ind,ic,gbound)

! Data is now ready to be extracted from fft box to sphere

 endif

! DEBUG
!write(6,*)' sg_fftpad : enter '
!write(6,*)allocated(arr)
!if(.true.) stop
! ENDDEBUG

 end subroutine
!!***


	subroutine depstor

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine computes maximum surface depressional storage depth based on
!!    random and oriented roughness and slope steepness

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!	hru_slp(:)	|m/m	       |average slope steepness in HRU
!!	iida		|julian date   |day being simulated (current julian day)
!!    iop(:,:,:)  |julian date   |date of tillage operation
!!    mgt_op      |none          |operation code number
!!    precipday   |mm H2O        |precipitation for the day in HRU
!!    ranrns_hru(:)|mm           |random roughness for a given HRU
!!    sol_bd(1,:) |Mg/m^3        |bulk density of top soil layer in HRU
!!    sol_cbn(1,:)|%             |percent organic carbon in top soil layer in HRU
!!	sol_clay(1,:)|% 		   |percent clay content in top soil layer in HRU
!!    sol_rsd(1,:)|kg/ha         |amount of organic matter in the top soil layer
!!                               |classified as residue in HRU
!!	sol_ori(:)	|mm			   |oriented roughness (ridges) at time of a given tillage operation
!!    sol_z(1,:)  |mm            |depth to bottom of top soil layer
!!    usle_ei     |100(ft-tn in)/(acre-hr)|USLE rainfall erosion index
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!	stmaxd(:)	|mm			   |maximum surface depressional storage for day in a given HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!	cumei(:)	|Mj*mm/ha*hr   |cumulative USLE rainfall erosion index since last
!!							   |tillage operation
!!	cumrt(:)	|mm H2O		   |cumulative rainfall since last tillage operation
!!	df  		|none		   |oriented and random roughness decay factor - based
!!                               |on cumulative EI and cumulative precipday
!!    ei          |Mj*mm/ha*hr   |USLE rainfall erosion index
!!	hru_slpp    |%	           |average percent slope steepness
!!	sol_orgm    |%      	   |percent organic matter content in soil material
!!	sol_rrr     |cm			   |random roughness after a rain event
!!	sol_orr     |cm			   |oriented roughness (ridges) after a rain event
!!    j           |none          |HRU number
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic:exp
!!    SWAT:eiusle

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use parm

      integer ::j
	real*8 :: df, hru_slpp, sol_orgm, sol_orr, sol_rrr, ei
      j = 0
      j = ihru

!! Calculate current cummulative erosivity and rainfall
	ei = usle_ei*18.7633
	if(itill(j) ==1)then
	  cumeira(j) = cumeira(j) + ei
	  cumei(j) = cumeira(j) - ei
	  cumrai(j) = cumrai(j) + precipday
	  cumrt(j) = cumrai(j) - precipday
      end if
!! Calculate the decay factor df based on %clay and %organic matter or %organic carbon
!	sol_orgm = (sol_rsd(1,j)*0.01)/(sol_z(1,j)*sol_bd(1,j))
	sol_orgm = sol_cbn(1,j)/0.58
	xx = (0.943 - 0.07 * sol_clay(1,j) + 0.0011 * sol_clay(1,j)**2
     &    - 0.67 * sol_orgm + 0.12 * sol_orgm**2)
      if (xx > 1.) then
        df = 1.
      else
        df = exp (xx)
      end if

!! Determine the current random and oriented roughness using cumei and cumrt and initial
!! random and oriented roughness values

	sol_rrr = 0.1*ranrns_hru(j)
     &	* exp(df*(-0.0009*cumei(j)-0.0007 * cumrt(j)))

!	sol_orr = 0.1*sol_ori(j)*                                                &
!     &	exp(df*(-0.025*(cumei(j)**0.31)-0.0085*(cumrt(j)**0.567)))

!! Compute the current maximum depressional storage using percent slope steepness
!! and current random and oriented roughness values determined above
	hru_slpp = hru_slp(j)*100
!	if(irk=0) then !irk=0 for random rough, and irk=1, for oriented roughness
	stmaxd(j)= 0.112*sol_rrr+0.031*sol_rrr**2-0.012*sol_rrr*hru_slpp
!	else
!	stmaxd(j)= 0.112*sol_orr+0.031*sol_orr**2-0.012*sol_orr*hru_slpp
!	endif

   	return
	end


! PR 29441 : No error was given for disallowed function in
! initialization expression, even if -std=f95 was used
! { dg-do compile }
! { dg-options "-std=f95" }
real, parameter :: pi = 4.0*Atan(1.0) ! { dg-error "Fortran 2003: Elemental function as initialization expression" }
real, parameter :: three = 27.0**(1.0/3.0) ! { dg-error "Noninteger exponent in an initialization expression" }
end