!==========================================================================
elemental subroutine gsw_pot_enthalpy_ice_freezing_first_derivatives_poly(&
         sa, p, pot_enthalpy_ice_freezing_sa, pot_enthalpy_ice_freezing_p)
!==========================================================================
!
!  Calculates the first derivatives of the potential enthalpy of ice Ih at
!  which ice melts into seawater with Absolute Salinity SA and at pressure
!  p.  This code uses the comptationally efficient polynomial fit of the
!  freezing potential enthalpy of ice Ih (McDougall et al., 2015).
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  pot_enthalpy_ice_freezing_SA = the derivative of the potential enthalpy
!                of ice at freezing (ITS-90) with respect to Absolute
!                salinity at fixed pressure  [ (J/kg)/(g/kg) ] i.e. [ J/g ]
!
!  pot_enthalpy_ice_freezing_P  = the derivative of the potential enthalpy
!                of ice at freezing (ITS-90) with respect to pressure
!                (in Pa) at fixed Absolute Salinity           [ (J/kg)/Pa ]
!--------------------------------------------------------------------------

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, p
real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_sa
real (r8), intent(out), optional :: pot_enthalpy_ice_freezing_p

real (r8) :: p_r, sa_r, x

real (r8), parameter :: d1 =  -1.249490228128056e4_r8
real (r8), parameter :: d2 =   1.336783910789822e4_r8
real (r8), parameter :: d3 =  -4.811989517774642e4_r8
real (r8), parameter :: d4 =   8.044864276240987e4_r8
real (r8), parameter :: d5 =  -7.124452125071862e4_r8
real (r8), parameter :: d6 =   2.280706828014839e4_r8
real (r8), parameter :: d7 =   0.315423710959628e3_r8
real (r8), parameter :: d8 =  -3.592775732074710e2_r8
real (r8), parameter :: d9 =   1.644828513129230e3_r8
real (r8), parameter :: d10 = -4.809640968940840e3_r8
real (r8), parameter :: d11 =  2.901071777977272e3_r8
real (r8), parameter :: d12 = -9.218459682855746e2_r8
real (r8), parameter :: d13 =  0.379377450285737e3_r8
real (r8), parameter :: d14 = -2.672164989849465e3_r8
real (r8), parameter :: d15 =  5.044317489422632e3_r8
real (r8), parameter :: d16 = -2.631711865886377e3_r8
real (r8), parameter :: d17 = -0.160245473297112e3_r8
real (r8), parameter :: d18 =  4.029061696035465e2_r8
real (r8), parameter :: d19 = -3.682950019675760e2_r8

real (r8), parameter :: f1 =  -2.034535061416256e4_r8
real (r8), parameter :: f2 =   0.315423710959628e3_r8
real (r8), parameter :: f3 =  -0.239518382138314e3_r8
real (r8), parameter :: f4 =   0.822414256564615e3_r8
real (r8), parameter :: f5 =  -1.923856387576336e3_r8
real (r8), parameter :: f6 =   0.967023925992424e3_r8
real (r8), parameter :: f7 =  -0.263384562367307e3_r8
real (r8), parameter :: f8 =  -5.051613740291480e3_r8
real (r8), parameter :: f9 =   7.587549005714740e2_r8
real (r8), parameter :: f10 = -3.562886653132620e3_r8
real (r8), parameter :: f11 =  5.044317489422632e3_r8
real (r8), parameter :: f12 = -2.105369492709102e3_r8
real (r8), parameter :: f13 =  6.387082316647800e2_r8
real (r8), parameter :: f14 = -4.807364198913360e2_r8
real (r8), parameter :: f15 =  8.058123392070929e2_r8
real (r8), parameter :: f16 = -5.524425029513641e2_r8

sa_r = sa*1e-2_r8
x = sqrt(sa_r)
p_r = p*1e-4_r8

if (present(pot_enthalpy_ice_freezing_sa)) pot_enthalpy_ice_freezing_sa = &
   (d1 + x*(d2  + x*(d3  + x*(d4  + x*(d5  + d6*x)))) &
       + p_r*(d7 + x*(d8 + x*(d9 + x*(d10 + x*(d11 + d12*x)))) &
       + p_r*(d13 + x*(d14 + x*(d15 + d16*x)) &
       + p_r*(d17 + x*(d18 + d19*x)))))*1e-2_r8

if (present(pot_enthalpy_ice_freezing_p)) pot_enthalpy_ice_freezing_p = &
   (f1 + sa_r*(f2 + x*(f3 + x*(f4 + x*(f5 + x*(f6 + f7*x))))) &
       + p_r*(f8 + sa_r*(f9 + x*(f10 + x*(f11 + f12*x))) &
       + p_r*(f13 + sa_r*(f14 + x*(f15 + f16*x)))))*1e-8_r8

return
end subroutine

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


subroutine migration_timescales
! Subroutine calculates migration timescales
! Returns the migration regime 'migtype' also

use embryodata
use stardata
use eosdata, only: yr,udist,umass

implicit none

integer :: i,j
real :: vmig, aspectratio,massratio, r_hill, pressure_crit

do j=1,nembryo

   if(embryo(j)%finished==1) cycle

   ! Find embryo in disc

   i = embryo(j)%icurrent

   ! If embryo outside the disc, then migration timescales are infinite
   if(i>irout) then
      embryo(j)%tcross = 1.0e30*yr
      embryo(j)%tgap = 1.0e30*yr
      embryo(j)%tmig = 1.0e30*yr
      cycle

   else

      aspectratio = H_d(i)/embryo(j)%a
      massratio = embryo(j)%m/mstar

      ! Calculate gap opening criteria

      ! First check Crida et al (2006) pressure criterion

      r_hill = embryo(j)%a*(massratio/3.0)**0.333

      pressure_crit = 0.75*H_d(i)/r_hill + &
           50.0*alpha_d(i)*cs_d(i)*aspectratio/(massratio*r_d(i)*omega_d(i))

      ! Check if gap opening time less than crossing time
      ! (assume type I migration timescale initially

      IF(sigma_d(i)>0.0) THEN
         embryo(j)%tmig = c_mig*aspectratio/(omega_d(i)*massratio)
      ELSE
         embryo(j)%tmig = 1.0e30*yr
      ENDIF

      vmig = r_d(i)/embryo(j)%tmig

      embryo(j)%tcross = 2.5*r_hill/vmig
      embryo(j)%tgap = c_gap*(aspectratio**5)/(omega_d(i)*massratio*massratio)

      ! Assume gap opens before testing - migration type II
      embryo(j)%migtype = 2

      ! Failure to open a gap results in type I migration

      ! If crossing time too short to open gap, no gap opens
      if( embryo(j)%tcross <  embryo(j)%tgap)  embryo(j)%migtype = 1
      ! If pressure criterion not met, gap doesn't open
      if(pressure_crit>1.0) embryo(j)%migtype = 1

      ! Calculate migration timescale (depending on regime)

      IF(embryo(j)%migtype==1)THEN
         ! Type I - Multiply migration timescale by tunable migration parameter
         IF(sigma_d(i)>0.0) THEN
            embryo(j)%tmig = c_mig*aspectratio/(omega_d(i)*massratio)
         ELSE
            embryo(j)%tmig = 1.0e30*yr
         ENDIF

      ELSE
         ! Type II - tunable migration parameter not effective here
         IF(alpha_d(i)*omega_d(i)*aspectratio >=0.0) THEN
            embryo(j)%tmig = 2.0/(3.0*alpha_d(i)*omega_d(i)*aspectratio*aspectratio)
         ELSE
            embryo(j)%tmig = 1.0e30*yr
         ENDIF

      ENDIF

      if(debug=='y') then

         write(*,'(A,1P,I1,X,I1,1P,6e18.4)') 'Migration timescales: ', j, &
              embryo(j)%migtype,  embryo(j)%a/udist,embryo(j)%m/mjup, &
              pressure_crit,  embryo(j)%tmig/yr,  embryo(j)%tcross/yr, &
              embryo(j)%tgap/yr
      endif
   endif

enddo

end subroutine migration_timescales


      SUBROUTINE SB08DD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
     $                   NQ, NR, CR, LDCR, DR, LDDR, TOL, DWORK, LDWORK,
     $                   IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To construct, for a given system G = (A,B,C,D), a feedback matrix
C     F, an orthogonal transformation matrix Z, and a gain matrix V,
C     such that the systems
C
C          Q = (Z'*(A+B*F)*Z, Z'*B*V, (C+D*F)*Z, D*V)
C     and
C          R = (Z'*(A+B*F)*Z, Z'*B*V, F*Z, V)
C
C     provide a stable right coprime factorization of G in the form
C                       -1
C              G = Q * R  ,
C
C     where G, Q and R are the corresponding transfer-function matrices
C     and the denominator R is inner, that is, R'(-s)*R(s) = I in the
C     continuous-time case, or R'(1/z)*R(z) = I in the discrete-time
C     case. The Z matrix is not explicitly computed.
C
C     Note: G must have no controllable poles on the imaginary axis
C     for a continuous-time system, or on the unit circle for a
C     discrete-time system. If the given state-space representation
C     is not stabilizable, the unstabilizable part of the original
C     system is automatically deflated and the order of the systems
C     Q and R is accordingly reduced.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the original system as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The dimension of the state vector, i.e. the order of the
C             matrix A, and also the number of rows of the matrix B and
C             the number of columns of the matrices C and CR.  N >= 0.
C
C     M       (input) INTEGER
C             The dimension of input vector, i.e. the number of columns
C             of the matrices B, D and DR and the number of rows of the
C             matrices CR and DR.  M >= 0.
C
C     P       (input) INTEGER
C             The dimension of output vector, i.e. the number of rows
C             of the matrices C and D.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the state dynamics matrix A. The matrix A must not
C             have controllable eigenvalues on the imaginary axis, if
C             DICO = 'C', or on the unit circle, if DICO = 'D'.
C             On exit, the leading NQ-by-NQ part of this array contains
C             the leading NQ-by-NQ part of the matrix Z'*(A+B*F)*Z, the
C             state dynamics matrix of the numerator factor Q, in a
C             real Schur form. The trailing NR-by-NR part of this matrix
C             represents the state dynamics matrix of a minimal
C             realization of the denominator factor R.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the input/state matrix.
C             On exit, the leading NQ-by-M part of this array contains
C             the leading NQ-by-M part of the matrix Z'*B*V, the
C             input/state matrix of the numerator factor Q. The last
C             NR rows of this matrix form the input/state matrix of
C             a minimal realization of the denominator factor R.
C
C     LDB     INTEGER
C             The leading dimension of 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 state/output matrix C.
C             On exit, the leading P-by-NQ part of this array contains
C             the leading P-by-NQ part of the matrix (C+D*F)*Z,
C             the state/output matrix of the numerator factor Q.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
C             On entry, the leading P-by-M part of this array must
C             contain the input/output matrix.
C             On exit, the leading P-by-M part of this array contains
C             the matrix D*V representing the input/output matrix
C             of the numerator factor Q.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,P).
C
C     NQ      (output) INTEGER
C             The order of the resulting factors Q and R.
C             Generally, NQ = N - NS, where NS is the number of
C             uncontrollable eigenvalues outside the stability region.
C
C     NR      (output) INTEGER
C             The order of the minimal realization of the factor R.
C             Generally, NR is the number of controllable eigenvalues
C             of A outside the stability region (the number of modified
C             eigenvalues).
C
C     CR      (output) DOUBLE PRECISION array, dimension (LDCR,N)
C             The leading M-by-NQ part of this array contains the
C             leading M-by-NQ part of the feedback matrix F*Z, which
C             reflects the eigenvalues of A lying outside the stable
C             region to values which are symmetric with respect to the
C             imaginary axis (if DICO = 'C') or the unit circle (if
C             DICO = 'D').  The last NR columns of this matrix form the
C             state/output matrix of a minimal realization of the
C             denominator factor R.
C
C     LDCR    INTEGER
C             The leading dimension of array CR.  LDCR >= MAX(1,M).
C
C     DR      (output) DOUBLE PRECISION array, dimension (LDDR,M)
C             The leading M-by-M part of this array contains the upper
C             triangular matrix V of order M representing the
C             input/output matrix of the denominator factor R.
C
C     LDDR    INTEGER
C             The leading dimension of array DR.  LDDR >= MAX(1,M).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The absolute tolerance level below which the elements of
C             B are considered zero (used for controllability tests).
C             If the user sets TOL <= 0, then an implicitly computed,
C             default tolerance, defined by  TOLDEF = N*EPS*NORM(B),
C             is used instead, where EPS is the machine precision
C             (see LAPACK Library routine DLAMCH) and NORM(B) denotes
C             the 1-norm of B.
C
C     Workspace
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 dimension of working array DWORK.
C             LDWORK >= MAX( 1, N*(N+5), M*(M+2), 4*M, 4*P ).
C             For optimum performance LDWORK should be larger.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = K:  K violations of the numerical stability condition
C                   NORM(F) <= 10*NORM(A)/NORM(B) occured during the
C                   assignment of eigenvalues.
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 reduction of A to a real Schur form failed;
C             = 2:  a failure was detected during the ordering of the
C                   real Schur form of A, or in the iterative process
C                   for reordering the eigenvalues of Z'*(A + B*F)*Z
C                   along the diagonal;
C             = 3:  if DICO = 'C' and the matrix A has a controllable
C                   eigenvalue on the imaginary axis, or DICO = 'D'
C                   and A has a controllable eigenvalue on the unit
C                   circle.
C
C     METHOD
C
C     The subroutine is based on the factorization algorithm of [1].
C
C     REFERENCES
C
C     [1] Varga A.
C         A Schur method for computing coprime factorizations with inner
C         denominators and applications in model reduction.
C         Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993.
C
C     NUMERICAL ASPECTS
C                                            3
C     The algorithm requires no more than 14N  floating point
C     operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen, July 1998.
C     Based on the RASP routine RCFID.
C
C     REVISIONS
C
C     Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest.
C     Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven.
C     Feb. 1999, May 2003, A. Varga, DLR Oberpfaffenhofen.
C
C     KEYWORDS
C
C     Coprime factorization, eigenvalue, eigenvalue assignment,
C     feedback control, pole placement, state-space model.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, TEN, ZERO
      PARAMETER         ( ONE = 1.0D0, TEN = 1.0D1, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO
      INTEGER           INFO, IWARN, LDA, LDB, LDC, LDCR, LDD, LDDR,
     $                  LDWORK, M, N, NQ, NR, P
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), CR(LDCR,*),
     $                  D(LDD,*), DR(LDDR,*), DWORK(*)
C     .. Local Scalars ..
      LOGICAL           DISCR
      INTEGER           I, IB, IB1, J, K, KFI, KV, KW, KWI, KWR, KZ, L,
     $                  L1, NB, NCUR, NFP, NLOW, NSUP
      DOUBLE PRECISION  ALPHA, BNORM, CS, PR, RMAX, SM, SN, TOLER,
     $                  WRKOPT, X, Y
C     .. Local Arrays ..
      DOUBLE PRECISION  Z(4,4)
C     .. External Functions ..
      DOUBLE PRECISION  DLAMCH, DLANGE
      LOGICAL           LSAME
      EXTERNAL          DLAMCH, DLANGE, LSAME
C     .. External Subroutines ..
      EXTERNAL          DGEMM, DLACPY, DLAEXC, DLANV2, DLASET, DROT,
     $                  DTRMM, DTRMV, SB01FY, TB01LD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX, MIN
C     .. Executable Statements ..
C
      DISCR = LSAME( DICO, 'D' )
      IWARN = 0
      INFO  = 0
C
C     Check the scalar input parameters.
C
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -10
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -12
      ELSE IF( LDCR.LT.MAX( 1, M ) ) THEN
         INFO = -16
      ELSE IF( LDDR.LT.MAX( 1, M ) ) THEN
         INFO = -18
      ELSE IF( LDWORK.LT.MAX( 1, N*(N+5), M*(M+2), 4*M, 4*P ) ) THEN
         INFO = -21
      END IF
      IF( INFO.NE.0 )THEN
C
C        Error return.
C
         CALL XERBLA( 'SB08DD', -INFO )
         RETURN
      END IF
C
C     Set DR = I and quick return if possible.
C
      NR = 0
      IF( MIN( M, P ).GT.0 )
     $   CALL DLASET( 'Full', M, M, ZERO, ONE, DR, LDDR )
      IF( MIN( N, M ).EQ.0 ) THEN
         NQ = 0
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Set F = 0 in the array CR.
C
      CALL DLASET( 'Full', M, N, ZERO, ZERO, CR, LDCR )
C
C     Compute the norm of B and set the default tolerance if necessary.
C
      BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK )
      TOLER = TOL
      IF( TOLER.LE.ZERO )
     $   TOLER = DBLE( N ) * BNORM * DLAMCH( 'Epsilon' )
      IF( BNORM.LE.TOLER ) THEN
         NQ = 0
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Compute the bound for the numerical stability condition.
C
      RMAX = TEN * DLANGE( '1-norm', N, N, A, LDA, DWORK ) / BNORM
C
C     Allocate working storage.
C
      KZ  = 1
      KWR = KZ  + N*N
      KWI = KWR + N
      KW  = KWI + N
C
C     Reduce A to an ordered real Schur form using an orthogonal
C     similarity transformation A <- Z'*A*Z and accumulate the
C     transformations in Z.  The separation of spectrum of A is
C     performed such that the leading NFP-by-NFP submatrix of A
C     corresponds to the "stable" eigenvalues which will be not
C     modified. The bottom (N-NFP)-by-(N-NFP) diagonal block of A
C     corresponds to the "unstable" eigenvalues to be modified.
C     Apply the transformation to B and C: B <- Z'*B and C <- C*Z.
C
C     Workspace needed:      N*(N+2);
C     Additional workspace:  need   3*N;
C                            prefer larger.
C
      IF( DISCR ) THEN
         ALPHA = ONE
      ELSE
         ALPHA = ZERO
      END IF
      CALL TB01LD( DICO, 'Stable', 'General', N, M, P, ALPHA, A, LDA,
     $             B, LDB, C, LDC, NFP, DWORK(KZ), N, DWORK(KWR),
     $             DWORK(KWI), DWORK(KW), LDWORK-KW+1, INFO )
      IF( INFO.NE.0 )
     $    RETURN
C
      WRKOPT = DWORK(KW) + DBLE( KW-1 )
C
C     Perform the pole assignment if there exist "unstable" eigenvalues.
C
      NQ = N
      IF( NFP.LT.N ) THEN
         KV  = 1
         KFI = KV  + M*M
         KW  = KFI + 2*M
C
C        Set the limits for the bottom diagonal block.
C
         NLOW = NFP + 1
         NSUP = N
C
C        WHILE (NLOW <= NSUP) DO
   10    IF( NLOW.LE.NSUP ) THEN
C
C           Main loop for assigning one or two poles.
C
C           Determine the dimension of the last block.
C
            IB = 1
            IF( NLOW.LT.NSUP ) THEN
               IF( A(NSUP,NSUP-1).NE.ZERO ) IB = 2
            END IF
            L = NSUP - IB + 1
C
C           Check the controllability of the last block.
C
            IF( DLANGE( '1-norm', IB, M, B(L,1), LDB, DWORK(KW) )
     $            .LE.TOLER ) THEN
C
C              Deflate the uncontrollable block and resume the main
C              loop.
C
               NSUP = NSUP - IB
            ELSE
C
C              Determine the M-by-IB feedback matrix FI which assigns
C              the selected IB poles for the pair
C              ( A(L:L+IB-1,L:L+IB-1), B(L:L+IB-1,1:M) ).
C
C              Workspace needed: M*(M+2).
C
               CALL SB01FY( DISCR, IB, M, A(L,L), LDA, B(L,1), LDB,
     $                      DWORK(KFI), M, DWORK(KV), M, INFO )
               IF( INFO.EQ.2 ) THEN
                  INFO = 3
                  RETURN
               END IF
C
C              Check for possible numerical instability.
C
               IF( DLANGE( '1-norm', M, IB, DWORK(KFI), M, DWORK(KW) )
     $               .GT.RMAX ) IWARN = IWARN + 1
C
C              Update the state matrix A <-- A + B*[0 FI].
C
               CALL DGEMM( 'NoTranspose', 'NoTranspose', NSUP, IB, M,
     $                     ONE, B, LDB, DWORK(KFI), M, ONE, A(1,L),
     $                     LDA )
C
C              Update the feedback matrix F <-- F + V*[0 FI] in CR.
C
               IF( DISCR )
     $            CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit',
     $                        M, IB, ONE, DR, LDDR, DWORK(KFI), M )
               K = KFI
               DO 30 J = L, L + IB - 1
                  DO 20 I = 1, M
                     CR(I,J) = CR(I,J) + DWORK(K)
                     K = K + 1
   20             CONTINUE
   30          CONTINUE
C
               IF( DISCR ) THEN
C
C                 Update the input matrix B <-- B*V.
C
                  CALL DTRMM( 'Right', 'Upper', 'NoTranspose',
     $                        'NonUnit', N, M, ONE, DWORK(KV), M, B,
     $                        LDB )
C
C                 Update the feedthrough matrix DR <-- DR*V.
C
                  K = KV
                  DO 40 I = 1, M
                     CALL DTRMV( 'Upper', 'Transpose', 'NonUnit',
     $                           M-I+1, DWORK(K), M, DR(I,I), LDDR )
                     K = K + M + 1
   40             CONTINUE
               END IF
C
               IF( IB.EQ.2 ) THEN
C
C                 Put the 2x2 block in a standard form.
C
                  L1 = L + 1
                  CALL DLANV2( A(L,L), A(L,L1), A(L1,L), A(L1,L1),
     $                         X, Y, PR, SM, CS, SN )
C
C                 Apply the transformation to A, B, C and F.
C
                  IF( L1.LT.NSUP )
     $               CALL DROT( NSUP-L1, A(L,L1+1), LDA, A(L1,L1+1),
     $                          LDA, CS, SN )
                  CALL DROT( L-1, A(1,L), 1, A(1,L1), 1, CS, SN )
                  CALL DROT( M, B(L,1), LDB, B(L1,1), LDB, CS, SN )
                  IF( P.GT.0 )
     $               CALL DROT( P, C(1,L), 1, C(1,L1), 1, CS, SN )
                  CALL DROT( M, CR(1,L), 1, CR(1,L1), 1, CS, SN )
               END IF
               IF( NLOW+IB.LE.NSUP ) THEN
C
C                 Move the last block(s) to the leading position(s) of
C                 the bottom block.
C
C                 Workspace:     need MAX(4*N, 4*M, 4*P).
C
                  NCUR = NSUP - IB
C                 WHILE (NCUR >= NLOW) DO
   50             IF( NCUR.GE.NLOW ) THEN
C
C                    Loop for positioning of the last block.
C
C                    Determine the dimension of the current block.
C
                     IB1 = 1
                     IF( NCUR.GT.NLOW ) THEN
                         IF( A(NCUR,NCUR-1).NE.ZERO ) IB1 = 2
                     END IF
                     NB = IB1 + IB
C
C                    Initialize the local transformation matrix Z.
C
                     CALL DLASET( 'Full', NB, NB, ZERO, ONE, Z, 4 )
                     L = NCUR - IB1 + 1
C
C                    Exchange two adjacent blocks and accumulate the
C                    transformations in Z.
C
                     CALL DLAEXC( .TRUE., NB, A(L,L), LDA, Z, 4, 1, IB1,
     $                            IB, DWORK, INFO )
                     IF( INFO.NE.0 ) THEN
                        INFO = 2
                        RETURN
                     END IF
C
C                    Apply the transformation to the rest of A.
C
                     L1 = L + NB
                     IF( L1.LE.NSUP ) THEN
                        CALL DGEMM( 'Transpose', 'NoTranspose', NB,
     $                              NSUP-L1+1, NB, ONE, Z, 4, A(L,L1),
     $                              LDA, ZERO, DWORK, NB )
                        CALL DLACPY( 'Full', NB, NSUP-L1+1, DWORK, NB,
     $                               A(L,L1), LDA )
                     END IF
                     CALL DGEMM( 'NoTranspose', 'NoTranspose', L-1, NB,
     $                           NB, ONE, A(1,L), LDA, Z, 4, ZERO,
     $                           DWORK, N )
                     CALL DLACPY( 'Full', L-1, NB, DWORK, N, A(1,L),
     $                            LDA )
C
C                    Apply the transformation to B, C and F.
C
                     CALL DGEMM( 'Transpose', 'NoTranspose', NB, M, NB,
     $                           ONE, Z, 4, B(L,1), LDB, ZERO, DWORK,
     $                           NB )
                     CALL DLACPY( 'Full', NB, M, DWORK, NB, B(L,1),
     $                            LDB )
C
                     IF( P.GT.0 ) THEN
                        CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NB,
     $                              NB, ONE, C(1,L), LDC, Z, 4, ZERO,
     $                              DWORK, P )
                        CALL DLACPY( 'Full', P, NB, DWORK, P,
     $                               C(1,L), LDC )
                     END IF
C
                     CALL DGEMM( 'NoTranspose', 'NoTranspose', M, NB,
     $                           NB, ONE, CR(1,L), LDCR, Z, 4, ZERO,
     $                           DWORK, M )
                     CALL DLACPY( 'Full', M, NB, DWORK, M, CR(1,L),
     $                            LDCR )
C
                     NCUR = NCUR - IB1
                     GO TO 50
                  END IF
C                 END WHILE 50
C
               END IF
               NLOW = NLOW + IB
            END IF
            GO TO 10
         END IF
C        END WHILE 10
C
         NQ = NSUP
         NR = NSUP - NFP
C
C        Annihilate the elements below the first subdiagonal of A.
C
         IF( NQ.GT.2 )
     $      CALL DLASET( 'Lower', NQ-2, NQ-2, ZERO, ZERO, A(3,1), LDA )
      END IF
C
C     Compute C <-- CQ = C + D*F and D <-- DQ = D*DR.
C
      CALL DGEMM( 'NoTranspose', 'NoTranspose', P, NQ, M, ONE, D, LDD,
     $            CR, LDCR, ONE, C, LDC )
      IF( DISCR )
     $   CALL DTRMM( 'Right', 'Upper', 'NoTranspose', 'NonUnit', P, M,
     $               ONE, DR, LDDR, D, LDD )
C
      DWORK(1) = MAX( WRKOPT, DBLE( MAX( M*(M+2), 4*M, 4*P ) ) )
C
      RETURN
C *** Last line of SB08DD ***
      END


c
c**************************************
c
        subroutine frstdif(x,nch,npts,lfd,id,areg,npw,r,aa,bb,work)

c    computes first difference of nch channels of data, each of length
c       npts

c       routine heavily modified by ping zhang to do adaptive
c      prewhitening using ar approach

c       fixed by egbert to stabilize ar prewhitening coefficients
c
c      still suspect, June 1993 !!!!!

        integer npw(*)
        real x(nch,npts),areg(nch,*),r(npts),aa(npts),work(npts)
        real bb(npts)
        logical lfd(nch,*)

        do 10 i=1,nch
        ntem=npw(i)-1
        if( lfd(i,id) ) then
           do 5 j=1,npts
           x(i,j)=x(i,j+1)-x(i,j)
5          continue
         else if(ntem.ge.1) then
c***           use autoregressive model to find coefficients

c**          find autocrrelation function
         call autocor(x,npts,ntem,nch,i,r,aa)
c**   solve system equations for coefficients

         do 30 k=1,ntem
         bb(k)=r(k+1)
 30      continue
         call chdec(aa,work,ntem,ier)
         if(ier.lt.0) then
c            print*,'cholesky decomp failed in prewhitener'
c            print*,'channel = ',i
c            print*,aa(1)
c            print*,aa(2),aa(3)
c            print*,aa(4),aa(5),aa(6)
            do 35 k = 2,npw(i)
35          areg(i,k) = 0.
            areg(i,1) = 1.
            go to 10
         end if

         call ltslv(work,ntem,bb,1)
         ns=ntem/2
         do 100 k1=1,ns
         temp=bb(k1)
         bb(k1)=bb(ntem-k1+1)
         bb(ntem-k1+1)=temp
 100     continue
         ntol=ntem*(ntem+1)/2
         ns=ntol/2
         do 200 k1=1,ns
         temp=work(k1)
         work(k1)=work(ntol-k1+1)
         work(ntol-k1+1)=temp
 200     continue
         call ltslv(work,ntem,bb,1)
         do 40 j=1,ntem
         areg(i,j+1)=-bb(ntem-j+1)
 40      continue
         areg(i,1)=1.

c**   construct new data series
         do 50 j=1,npts
         xtem=0.
         do 60 k=1,npw(i)
         xtem=xtem+areg(i,k)*x(i,j+npw(i)-k)
 60      continue
         x(i,j)=xtem
 50      continue
        end if

10      continue
900     return
        end


      SUBROUTINE PHO_QPMPDF(Iq,X,Scale2,Ptref,Pvirt,Fxp)
C***************************************************************
C
C     contribution to photon PDF from box graph
C     (Bethe-Heitler process)
C
C     input:      IQ       quark flavour
C                 SCALE2   scale (GeV**2, positive)
C                 PTREF    reference scale (GeV, positive)
C                 X        parton momentum fraction
C                 PVIRT    photon virtuality (GeV**2, positive)
C                 FXP      x*f(x,Q**2), x times parton density
C
C***************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION be , bm , bp , Fxp , Ptref , Pvirt , qm , qm2 ,
     &                 Scale2 , w2 , X
      INTEGER i , Iq
      SAVE

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  internal rejection counters
      INCLUDE 'inc/poloop'
C  some constants
      INCLUDE 'inc/pocons'

      DIMENSION qm(6)
      DATA qm/0.2D0 , 0.25D0 , 0.5D0 , 1.5D0 , 4.5D0 , 174.D0/

      Fxp = 0.D0
      i = ABS(Iq)
C
C     QM2 = MAX(QM(I),PTREF)**2
C     QM2 = MAX(QM2,PVIRT)
C     BBE = (1.D0-X)*SCALE2
C     IF(BBE.LE.0.D0) THEN
C       IF(IDEB(27).GE.5) WRITE(LO,'(1X,A,4E10.3)')
C    &    'PHO_QPMPDF: over mass limit (X,Q2,P2,QM)',X,SCALE2,
C    &    PVIRT,QM(I)
C     ENDIF
C     FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(2.D0*137.D0*PI)
C    &  *((X**2+(1.D0-X)**2)*LOG(BBE/(QM2*X))+8.D0*X*(1.D0-X)-1.D0)
C  Bethe-Heitler process approximation for 2*x*p2/q2 << 1
      qm2 = MAX(qm(i),Ptref)**2
      w2 = Scale2/X*(1.D0-X-X*Pvirt/Scale2)
      IF ( w2.GT.4.D0*qm2 ) THEN
         be = SQRT(1.D0-4.D0*qm2/w2)
         bp = SQRT(1.D0+be*(1.D0-4.D0*X*X*Pvirt/Scale2))
         bm = SQRT(1.D0-be*(1.D0-4.D0*X*X*Pvirt/Scale2))
C       FXP = X*(4.D0-3.D0*MOD(I,2))/9.D0*3.D0/(137.D0*PI)*(BE*(-1.D0
         Fxp = X*Q_Ch2(i)*3.D0/(137.D0*PI)
     &         *(be*(-1.D0+6.D0*X-6.D0*X*X)+2.D0*X*X*((2.D0*qm2-Pvirt)
     &         /Scale2-4.D0*qm2*qm2/Scale2**2)*(1.D0/bm-1.D0/bp)
     &         +(X*X+(1.D0-X)**2+X*(1-3.D0*X)*4.D0*qm2/Scale2-
     &         X*X*8.D0*qm2*qm2/Scale2**2)*LOG(bp/bm))
      ELSE
         IF ( LPRi.GT.4 .AND. IDEb(27).GE.5 ) WRITE (LO,'(1X,A,4E10.3)')
     &         'PHO_QPMPDF: under mass limit (X,Q2,P2,QM)' , X ,
     &        Scale2 , Pvirt , qm(i)
      END IF
C  debug output
      IF ( LPRi.GT.4 .AND. IDEb(27).GE.20 )
     &      WRITE (LO,'(1X,A,I3,1P,5E10.3)') 'PHO_QPMPDF: X,Q2,P2,QM' ,
     &     i , X , Scale2 , Pvirt , qm(i) , Fxp
      END SUBROUTINE


subroutine compute_wind
!
! Compute the surface density loss due to winds
! Interpolates between X Ray Winds (Owen et al 2010)
! and FUV/EUV winds (Pont et al, Alexander et al)
!

use winddata
use gravdata
use unitdata

implicit none

integer :: i
real :: sigdot_diff, sigdot_dir,rdir_min
real :: xwind, sigdotxray

sigdot_wind(:) = 0.0

do i= isr,ier
Call wind_profiles(sigdot_diff,sigdot_dir,rz(i), mstar, rdir_min)

If (sigdot_diff.lt.0.0d0) sigdot_diff = 0.0d0
If (sigdot_dir.lt.0.0d0) sigdot_dir = 0.0d0

xwind = 0.85*(rz(i)/AU)*(mstar/solarmass)**(-1.0d0)

call xraywind(sigdotxray,xwind)
sigdotxray = sigdotxray*windnorm

sigdotxray = sigdotxray*msolyr

if(rz(i)/AU > rwind_xray) then

sigdot_wind(i) = rwind_xray*(sigdot_diff + sigdot_dir)

else
sigdot_wind(i) = sigdotxray
endif
enddo

end subroutine compute_wind


!==========================================================================
elemental subroutine gsw_ct_freezing_first_derivatives_poly (sa, p, &
                          saturation_fraction, ctfreezing_sa, ctfreezing_p)
!==========================================================================
!
!  Calculates the first derivatives of the Conservative Temperature at
!  which seawater freezes, with respect to Absolute Salinity SA and
!  pressure P (in Pa) of the comptationally efficient polynomial fit of the
!  freezing temperature (McDougall et al., 2014).
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!  saturation_fraction = the saturation fraction of dissolved air in
!                        seawater
!
!  CTfreezing_SA = the derivative of the Conservative Temperature at
!                  freezing (ITS-90) with respect to Absolute Salinity at
!                  fixed pressure              [ K/(g/kg) ] i.e. [ K kg/g ]
!
!  CTfreezing_P  = the derivative of the Conservative Temperature at
!                  freezing (ITS-90) with respect to pressure (in Pa) at
!                  fixed Absolute Salinity                         [ K/Pa ]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_sso

use gsw_mod_freezing_poly_coefficients

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, p, saturation_fraction
real (r8), intent(out), optional :: ctfreezing_sa, ctfreezing_p

real (r8) :: p_r, sa_r, x

real (r8), parameter :: d = -a - a*b - 2.4_r8*b/gsw_sso
real (r8), parameter :: e = 2.0_r8*a*b/gsw_sso

sa_r = sa*1e-2_r8
x = sqrt(sa_r)
p_r = p*1e-4_r8

if (present(ctfreezing_sa)) ctfreezing_sa = &
    (c1 + x*(1.5_r8*c2 + x*(2.0_r8*c3 + x*(2.5_r8*c4 + x*(3.0_r8*c5 &
        + 3.5_r8*c6*x)))) + p_r*(c10 + x*(1.5_r8*c11 + x*(2.0_r8*c13 &
	+ x*(2.5_r8*c16 + x*(3.0_r8*c19 + 3.5_r8*c22*x)))) &
        + p_r*(c12 + x*(1.5_r8*c14 + x*(2.0_r8*c17 + 2.5_r8*c20*x)) &
        + p_r*(c15 + x*(1.5_r8*c18 + 2.0_r8*c21*x)))))*1e-2_r8 &
	- saturation_fraction*1e-3_r8*(d - sa*e)

if (present(ctfreezing_p)) ctfreezing_p = &
    (c7 + sa_r*(c10 + x*(c11 + x*(c13 + x*(c16 + x*(c19 + c22*x))))) &
        + p_r*(2.0_r8*c8 + sa_r*(2.0_r8*c12 + x*(2.0_r8*c14 + x*(2.0_r8*c17 &
	+ 2.0_r8*c20*x))) + p_r*(3.0_r8*c9 + sa_r*(3.0_r8*c15 + x*(3.0_r8*c18 &
	+ 3.0_r8*c21*x)))))*1e-8_r8

return
end subroutine

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


! ******************************************************************************************************************************** !
! gem_geochem.f90
! Geochemistry (non carbonate chemistry) Model
! ******************************************************************************************************************************** !

MODULE gem_geochem

  use gem_cmn
  use gem_util
  IMPLICIT NONE
  SAVE

CONTAINS

  ! ****************************************************************************************************************************** !
  ! Fe SPECIATION
  function fun_box_calc_geochem_Fe(dum_FeT,dum_LT,dum_par_K_FeL)
    ! -------------------------------------------------------- !
    ! RESULT VARIABLE
    ! -------------------------------------------------------- !
    real,DIMENSION(1:3)::fun_box_calc_geochem_Fe
    ! -------------------------------------------------------- !
    ! DUMMY ARGUMENTS
    ! -------------------------------------------------------- !
    real,INTENT(in)::dum_FeT,dum_LT
    real,INTENT(in)::dum_par_K_FeL
    ! -------------------------------------------------------- !
    ! DEFINE LOCAL VARIABLES
    ! -------------------------------------------------------- !
    real::loc_Fe,loc_FeL,loc_L
    real,DIMENSION(2)::loc_roots
    ! -------------------------------------------------------- !
    ! CALCULATE IRON SPECIATION
    ! -------------------------------------------------------- !
    ! -------------------------------------------------------- ! solve Fe speciation equation
    ! K = FeL / (Fe*L) (e.g. see: Parekth et al. [2005])
    ! => FeL = Fe*L*K
    !    conservation relations:
    !    FeL + Fe = FeT => Fe = FeT - FeL
    !    FeL + L  = LT  => L  = LT  - FeL
    !    substitute:
    !    FeL = (FeT - FeL)*(LT - FeL)*K
    !    => FeL/K = FeT*LT + FeL^2 - LT*FeL - FeT*FeL
    !    => FeL/K = FeL^2 - (LT + FeT)*FeL + FeT*LT
    !    => 1.0*FeL^2 - (LT + FeT + 1.0/K)*FeL + FeT*LT = 0.0
    !       solve as: ax2 + bx + c = 0.0
    !                 where x = FeL
    loc_roots(:) = fun_quad_root(1.0,-(dum_LT + dum_FeT + 1.0/dum_par_K_FeL),dum_FeT*dum_LT)
    ! -------------------------------------------------------- ! filter returned roots
    if (maxval(loc_roots(:)) < const_real_nullsmall) then
       IF (ctrl_debug_reportwarnings) THEN
          CALL sub_report_error( &
               & 'biogem_box.f90','sub_calc_geochem_Fe', &
               & 'No REAL root in Fe speciation calculation (or maybe zero ...).'// &
               & ' / Data: loc_FeL(OLD),loc_Fe(OLD),loc_L(OLD),dum_FeT,dum_LT,', &
               & 'SOD THIS FOR A GAME OF SOLDIERS: calculation abondoned ...', &
               & (/loc_FeL,loc_Fe,loc_L,dum_FeT,dum_LT/),.false. &
               & )
          error_stop = .FALSE.
       end IF
    elseif ((minval(loc_roots(:)) > dum_FeT) .AND. (minval(loc_roots(:)) > dum_LT)) then
       IF (ctrl_debug_reportwarnings) THEN
          CALL sub_report_error( &
               & 'biogem_box.f90','sub_calc_geochem_Fe', &
               & 'No solution to Fe speciation calculation possible ... :('// &
               & ' / Data: loc_FeL(OLD),loc_Fe(OLD),loc_L(OLD),dum_FeT,dum_LT,', &
               & 'SOD THIS FOR A GAME OF SOLDIERS: calculation abondoned ...', &
               & (/loc_FeL,loc_Fe,loc_L,dum_FeT,dum_LT/),.false. &
               & )
          error_stop = .FALSE.
       end IF
    else
       if (minval(loc_roots(:)) < const_real_nullsmall) then
          loc_FeL = maxval(loc_roots(:))
       else
          loc_FeL = minval(loc_roots(:))
       end if
       loc_Fe  = dum_FeT - loc_FeL
       loc_L   = dum_LT - loc_FeL
    end if
    ! -------------------------------------------------------- !
    ! RETURN RESULT
    ! -------------------------------------------------------- !
    fun_box_calc_geochem_Fe(1) = loc_Fe
    fun_box_calc_geochem_Fe(2) = loc_FeL
    fun_box_calc_geochem_Fe(3) = loc_L
    ! -------------------------------------------------------- !
    ! END
    ! -------------------------------------------------------- !
  end function fun_box_calc_geochem_Fe
  ! ****************************************************************************************************************************** !

  ! ****************************************************************************************************************************** !
  ! CALCULATE SOLUBILITY COEFFICIENT
  function fun_calc_solconst(dum_ia,dum_T,dum_S,dum_rho)
    ! result variable
    REAL::fun_calc_solconst
    ! dummy arguments
    integer,INTENT(in)::dum_ia
    real,INTENT(in)::dum_T,dum_S,dum_rho
    ! local variables
    REAL::loc_T,loc_rT,loc_Tr100,loc_S
    ! calculate local constants
    ! NOTE: pressure in units of (bar) (1 m depth approx = 1 dbar pressure)
    ! NOTE: temperature in K
    ! NOTE: restrict valid T,S range for empirical fit
    ! NOTE: original default was the same as for Mehrbach K1, K2 CONSTANTS:
    !       2.0  <= T <= 35 C
    !       26.0 <= S <= 43 PSU
    ! NOTE: hence carbchem_*, rather than geochem_* parameter set (logically: geochem_* as per air-sea gas exchange ...)
    if (dum_T <  (const_zeroC +  par_carbchem_Tmin))  then
       loc_T = const_zeroC +  par_carbchem_Tmin
    elseif (dum_T > (const_zeroC + par_carbchem_Tmax)) then
       loc_T = const_zeroC + par_carbchem_Tmax
    else
       loc_T = dum_T
    endif
    if (dum_S < par_carbchem_Smin) then
       loc_S = par_carbchem_Smin
    elseif (dum_S > par_carbchem_Smax) then
       loc_S = par_carbchem_Smax
    else
       loc_S = dum_S
    endif
    ! set local constants
    loc_rT    = 1.0/loc_T
    loc_Tr100 = loc_T/100.0
    ! calculate Solubility Coefficients (mol/(kg atm)) and return function value
    ! NOTE: for CO2 and N2O, the soluability coefficient is in units of mol/(kg atm)
    !       rather than as a Bunsen Solubility Coefficient (see Wanninkohf [1992])
    !       => convert units for others
    ! NOTE: for CFC-11 and CFC-12, the soluability coefficient is in units of mol/(kg atm)
    !       rather than as a Bunsen Solubility Coefficient (see Wanninkohf [1992])
    !       (actaully, it is not really this simple and K should be corrected for water vapour pressure and lame things like that)
    SELECT CASE (dum_ia)
    CASE (ia_pCO2,ia_pN2O)
       fun_calc_solconst = EXP( &
            & par_bunsen_coef(1,dum_ia) + par_bunsen_coef(2,dum_ia)*(100*loc_rT) + par_bunsen_coef(3,dum_ia)*LOG(loc_Tr100) + &
            & loc_S* &
            & (par_bunsen_coef(4,dum_ia) + par_bunsen_coef(5,dum_ia)*(loc_Tr100) + par_bunsen_coef(6,dum_ia)*(loc_Tr100)**2) &
            &  )
    CASE (ia_pCFC11,ia_pCFC12)
       fun_calc_solconst = EXP( &
            & par_bunsen_coef(1,dum_ia) + par_bunsen_coef(2,dum_ia)*(100*loc_rT) + par_bunsen_coef(3,dum_ia)*LOG(loc_Tr100) + &
            & loc_S* &
            & (par_bunsen_coef(4,dum_ia) + par_bunsen_coef(5,dum_ia)*(loc_Tr100) + par_bunsen_coef(6,dum_ia)*(loc_Tr100)**2) &
            &  )
    CASE default
       fun_calc_solconst = EXP( &
            & par_bunsen_coef(1,dum_ia) + par_bunsen_coef(2,dum_ia)*(100*loc_rT) + par_bunsen_coef(3,dum_ia)*LOG(loc_Tr100) + &
            & loc_S* &
            & (par_bunsen_coef(4,dum_ia) + par_bunsen_coef(5,dum_ia)*(loc_Tr100) + par_bunsen_coef(6,dum_ia)*(loc_Tr100)**2) &
            &  )/ &
            & (dum_rho*const_V)
    END SELECT
  end function fun_calc_solconst
  ! ****************************************************************************************************************************** !

  ! ****************************************************************************************************************************** !
  function fun_box_calc_spec_Fe2(dum_Fe2,dum_H2S,dum_par_bio_FeS_abioticohm_cte)
    ! -------------------------------------------------------- !
    ! RESULT VARIABLE
    ! -------------------------------------------------------- !
    real,DIMENSION(1:3)::fun_box_calc_spec_Fe2
    ! -------------------------------------------------------- !
    ! DUMMY ARGUMENTS
    ! -------------------------------------------------------- !
    real,INTENT(in)::dum_Fe2,dum_H2S
    real,INTENT(in)::dum_par_bio_FeS_abioticohm_cte
    ! -------------------------------------------------------- !
    ! DEFINE LOCAL VARIABLES
    ! -------------------------------------------------------- !
    real::loc_Fe2,loc_H2S,loc_FeS
    real,DIMENSION(2)::loc_roots
    ! -------------------------------------------------------- !
    ! CALCULATE reduced IRON SPECIATION
    ! -------------------------------------------------------- !
    ! -------------------------------------------------------- ! solve reduced Fe speciation equation
    !
    ! calculate solution for equilibrium:
    ! Fe2_eq*H2S_eq/FeS_eq = K
    ! Fe2_eq = Fe2_in - x; H2S_eq = H2S_in - x; FeS_eq = FeS_in + x
    ! (Fe2_in - x)(H2S_in - x) = K*FeS_in + K*x
    ! Fe_in*H2S_in - H2S_in*x - Fe_in*x + x^2 = K*FeS_in + K*x
    ! x^2 - (H2S_in + Fe_in + K) + (Fe_in*H2S_in - K*FeS_in) = 0

    ! K = Fe2_eq*H2S_eq/FeS_eq
    ! => Fe2_eq*H2S_eq = K*FeS_eq
    !    conservation relations:
    !    Fe2_eq + FeS_eq = Fe2_tot => Fe2_eq = Fe2_tot - FeS_eq
    !    H2S_eq + FeS_eq = H2S_tot => H2S_eq = H2S_tot - FeS_eq
    !    substitute:
    !    (Fe2_tot - FeS_eq)(H2S_tot - FeS_eq) = K*FeS_eq
    !    => Fe2_tot*H2S_tot - Fe2_tot*FeS_eq - H2S_tot*FeS_eq + FeS_eq^2 = K*FeS_eq
    !    => 1.0*FeS_eq^2 - (Fe2_tot + H2S_tot + K) + Fe2_tot*H2S_tot = 0.0
    !    solve as: ax2 + bx + c = 0.0
    !                 where x = FeS_eq
    loc_roots(:) = fun_quad_root(1.0,-(dum_Fe2 + dum_H2S + dum_par_bio_FeS_abioticohm_cte),dum_Fe2*dum_H2S)
    ! -------------------------------------------------------- ! filter returned roots
    if (maxval(loc_roots(:)) < const_real_nullsmall) then
       IF (ctrl_debug_reportwarnings) THEN
          CALL sub_report_error( &
               & 'biogem_box.f90','sub_calc_spec_Fe2', &
               & 'No REAL root in Fe2 speciation calculation (or maybe zero ...).'// &
               & ' / Data: loc_Fe2(OLD),loc_H2S(OLD),loc_FeS(OLD),dum_Fe2,dum_H2S,', &
               & 'SOD THIS FOR A GAME OF SOLDIERS: calculation abondoned ...', &
               & (/loc_Fe2,loc_H2S,loc_FeS,dum_Fe2,dum_H2S/),.false. &
               & )
          error_stop = .FALSE.
       end IF
    elseif ((minval(loc_roots(:)) > dum_Fe2) .AND. (minval(loc_roots(:)) > dum_H2S)) then
       IF (ctrl_debug_reportwarnings) THEN
          CALL sub_report_error( &
               & 'biogem_box.f90','sub_calc_spec_Fe2', &
               & 'No solution to Fe2 speciation calculation possible ... :('// &
               & ' / Data: loc_Fe2(OLD),loc_H2S(OLD),loc_FeS(OLD),dum_Fe2,dum_H2S,', &
               & 'SOD THIS FOR A GAME OF SOLDIERS: calculation abondoned ...', &
               & (/loc_Fe2,loc_H2S,loc_FeS,dum_Fe2,dum_H2S/),.false. &
               & )
          error_stop = .FALSE.
       end IF
    else
       if (minval(loc_roots(:)) < const_real_nullsmall) then
          loc_FeS = maxval(loc_roots(:))
       else
          loc_FeS = minval(loc_roots(:))
       end if
       if (loc_FeS > MIN(dum_Fe2,dum_H2S)) then
           loc_FeS = MIN(dum_Fe2,dum_H2S)
       end if
       loc_Fe2  = dum_Fe2 - loc_FeS
       loc_H2S  = dum_H2S - loc_FeS
    end if
    ! -------------------------------------------------------- !
    ! RETURN RESULT
    ! -------------------------------------------------------- !
    fun_box_calc_spec_Fe2(1) = loc_Fe2
    fun_box_calc_spec_Fe2(2) = loc_H2S
    fun_box_calc_spec_Fe2(3) = loc_FeS
    ! -------------------------------------------------------- !
    ! END
    ! -------------------------------------------------------- !
  end function fun_box_calc_spec_Fe2
  !****************************************************************************************************************************** !

END MODULE gem_geochem


      SUBROUTINE slDDTF (NDP, DAYS, SIGN, IHMSF)
*+
*     - - - - - -
*      D D T F
*     - - - - - -
*
*  Convert an interval in days into hours, minutes, seconds
*  (double precision)
*
*  Given:
*     NDP      i      number of decimal places of seconds
*     DAYS     d      interval in days
*
*  Returned:
*     SIGN     c      '+' or '-'
*     IHMSF    i(4)   hours, minutes, seconds, fraction
*
*  Notes:
*
*     1)  NDP less than zero is interpreted as zero.
*
*     2)  The largest useful value for NDP is determined by the size
*         of DAYS, the format of DOUBLE PRECISION floating-point numbers
*         on the target machine, and the risk of overflowing IHMSF(4).
*         On some architectures, for DAYS up to 1D0, the available
*         floating-point precision corresponds roughly to NDP=12.
*         However, the practical limit is NDP=9, set by the capacity of
*         a typical 32-bit IHMSF(4).
*
*     3)  The absolute value of DAYS may exceed 1D0.  In cases where it
*         does not, it is up to the caller to test for and handle the
*         case where DAYS is very nearly 1D0 and rounds up to 24 hours,
*         by testing for IHMSF(1)=24 and setting IHMSF(1-4) to zero.
*
*  Last revision:   26 December 2004
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      INTEGER NDP
      DOUBLE PRECISION DAYS
      CHARACTER SIGN*(*)
      INTEGER IHMSF(4)

*  Days to seconds
      DOUBLE PRECISION D2S
      PARAMETER (D2S=86400D0)

      INTEGER NRS,N
      DOUBLE PRECISION RS,RM,RH,A,AH,AM,AS,AF

*  Handle sign
      IF (DAYS.GE.0D0) THEN
         SIGN='+'
      ELSE
         SIGN='-'
      END IF

*  Field units in terms of least significant figure
      NRS=1
      DO N=1,NDP
         NRS=NRS*10
      END DO
      RS=DBLE(NRS)
      RM=RS*60D0
      RH=RM*60D0

*  Round interval and express in smallest units required
      A=ANINT(RS*D2S*ABS(DAYS))

*  Separate into fields
      AH=AINT(A/RH)
      A=A-AH*RH
      AM=AINT(A/RM)
      A=A-AM*RM
      AS=AINT(A/RS)
      AF=A-AS*RS

*  Return results
      IHMSF(1)=MAX(NINT(AH),0)
      IHMSF(2)=MAX(MIN(NINT(AM),59),0)
      IHMSF(3)=MAX(MIN(NINT(AS),59),0)
      IHMSF(4)=MAX(NINT(MIN(AF,RS-1D0)),0)

      END


!< WenOOF test: 1D linear advection.

module wenoof_test_linear_advection_object
!< Definition of 1D linear advection.

use, intrinsic :: iso_fortran_env, only : stderr=>error_unit
use penf, only : I_P, R_P
use foodie, only : integrand
use wenoof, only : interpolator_object, wenoof_create

implicit none
private
public :: linear_advection_object

type, extends(integrand) :: linear_advection_object
   !< 1D linear advection field.
   !<
   !< It is a FOODIE integrand class concrete extension.
   !<
   !<### 1D linear advection field
   !< The 1D linear advection equation is a conservation law that reads as
   !<$$
   !<\begin{matrix}
   !<u_t = R(u)  \Leftrightarrow u_t = F(u)_x \\
   !<F(u) = a * u
   !<$$
   !< where `a` is scalar constant coefficient. The PDE must completed with the proper initial and boundary conditions.
   !<
   !<#### Numerical grid organization
   !< The finite volume, Godunov's like approach is employed. The conservative variables (and the primitive ones) are co-located at
   !< the cell center. The cell and (inter)faces numeration is as follow.
   !<```
   !<                cell            (inter)faces
   !<                 |                   |
   !<                 v                   v
   !<     |-------|-------|-.....-|-------|-------|-------|-------|-.....-|-------|-------|-------|-.....-|-------|-------|
   !<     | 1-Ng  | 2-Ng  | ..... |  -1   |   0   |   1   |  2    | ..... |  Ni   | Ni+1  | Ni+1  | ..... |Ni+Ng-1| Ni+Ng |
   !<     |-------|-------|-.....-|-------|-------|-------|-------|-.....-|-------|-------|-------|-.....-|-------|-------|
   !<    0-Ng                             -1      0       1       2      Ni-1     Ni                                    Ni+Ng
   !<```
   !< Where *Ni* are the finite volumes (cells) used for discretizing the domain and *Ng* are the ghost cells used for imposing the
   !< left and right boundary conditions (for a total of *2Ng* cells).
   integer(I_P)                            :: weno_order=0           !< WENO reconstruction order.
   real(R_P)                               :: weno_eps=10._R_P**(-6) !< WENO epsilon to avoid division by zero, default value.
   integer(I_P)                            :: Ni=0                   !< Space dimension.
   integer(I_P)                            :: Ng=0                   !< Ghost cells number.
   real(R_P)                               :: Dx=0._R_P              !< Space step.
   real(R_P)                               :: a=0._R_P               !< Advection coefficient.
   real(R_P), allocatable                  :: u(:)                   !< Integrand (state) variable.
   character(:), allocatable               :: BC_L                   !< Left boundary condition type.
   character(:), allocatable               :: BC_R                   !< Right boundary condition type.
   class(interpolator_object), allocatable :: interpolator           !< WENO interpolator.
   contains
      ! auxiliary methods
      procedure, pass(self) :: initialize       !< Initialize field.
      procedure, pass(self) :: destroy          !< Destroy field.
      procedure, pass(self) :: output           !< Extract advection field.
      procedure, pass(self) :: dt => compute_dt !< Compute the current time step, by means of CFL condition.
      ! ADT integrand deferred methods
      procedure, pass(self) :: t => dAdvection_dt                                           !< Time derivative, residuals function.
      procedure, pass(lhs)  :: local_error => advection_local_error                         !< Operator `||advection-advection||`.
      procedure, pass(lhs)  :: integrand_multiply_integrand => advection_multiply_advection !< Operator `*`.
      procedure, pass(lhs)  :: integrand_multiply_real => advection_multiply_real           !< Operator `advection * real`.
      procedure, pass(rhs)  :: real_multiply_integrand => real_multiply_advection           !< Operator `real * advection`.
      procedure, pass(lhs)  :: add => add_advection                                         !< Operator `+`.
      procedure, pass(lhs)  :: sub => sub_advection                                         !< Operator `-`.
      procedure, pass(lhs)  :: assign_integrand => advection_assign_advection               !< Operator `=`.
      procedure, pass(lhs)  :: assign_real => advection_assign_real                         !< Operator `advection = real`.
      ! private methods
      procedure, pass(self), private :: impose_boundary_conditions !< Impose boundary conditions.
      procedure, pass(self), private :: reconstruct_interfaces     !< Reconstruct interface states.
endtype linear_advection_object

contains
   ! auxiliary methods
   subroutine initialize(self, Ni, Dx, BC_L, BC_R, initial_state, s_scheme, a, weno_order)
   !< Initialize field.
   class(linear_advection_object), intent(inout)        :: self              !< Advection field.
   integer(I_P),                   intent(in)           :: Ni                !< Space dimension.
   real(R_P),                      intent(in)           :: Dx                !< Space step.
   character(*),                   intent(in)           :: BC_L              !< Left boundary condition type.
   character(*),                   intent(in)           :: BC_R              !< Right boundary condition type.
   real(R_P),                      intent(in)           :: initial_state(1:) !< Initial state.
   character(*),                   intent(in)           :: s_scheme          !< Space operator scheme.
   real(R_P),                      intent(in), optional :: a                 !< Advection coefficient.
   integer(I_P),                   intent(in), optional :: weno_order        !< WENO reconstruction order.
   integer(I_P)                                         :: i                 !< Space couner.

   call self%destroy
   self%a = 1._R_P ; if (present(a)) self%a = a
   self%weno_order = 1 ; if (present(weno_order)) self%weno_order = weno_order
   self%Ni = Ni
   self%Ng = (self%weno_order + 1) / 2
   self%Dx = Dx
   if (allocated(self%u)) deallocate(self%u) ; allocate(self%u(1-self%Ng:self%Ni+self%Ng))
   do i=1, Ni
      self%u(i) = initial_state(i)
   enddo
   self%BC_L = BC_L
   self%BC_R = BC_R

   if (self%weno_order>1) call wenoof_create(interpolator_type=trim(adjustl(s_scheme)), S=self%Ng, interpolator=self%interpolator, &
                                             eps=self%weno_eps)
   endsubroutine initialize

   pure subroutine destroy(self)
   !< Destroy field.
   class(linear_advection_object), intent(inout) :: self !< Advection field.

   self%weno_order = 0
   self%Ni = 0
   self%Ng = 0
   self%Dx = 0._R_P
   if (allocated(self%u)) deallocate(self%u)
   if (allocated(self%BC_L)) deallocate(self%BC_L)
   if (allocated(self%BC_R)) deallocate(self%BC_R)
   if (allocated(self%interpolator)) deallocate(self%interpolator)
   endsubroutine destroy

   pure function output(self) result(state)
   !< Output the advection field state.
   class(linear_advection_object), intent(in) :: self     !< Advection field.
   real(R_P), allocatable                     :: state(:) !< Advection state

   state = self%u(1:self%Ni)
   endfunction output

   pure function compute_dt(self, steps_max, t_max, t, CFL) result(Dt)
   !< Compute the current time step by means of CFL condition.
   class(linear_advection_object), intent(in) :: self      !< Advection field.
   integer(I_P),                   intent(in) :: steps_max !< Maximun number of time steps.
   real(R_P),                      intent(in) :: t_max     !< Maximum integration time.
   real(R_P),                      intent(in) :: t         !< Time.
   real(R_P),                      intent(in) :: CFL       !< CFL value.
   real(R_P)                                  :: Dt        !< Time step.

   associate(Ni=>self%Ni, Dx=>self%Dx)
      Dt = Dx * CFL / abs(self%a)
      if (steps_max <= 0 .and. t_max > 0._R_P) then
         if ((t + Dt) > t_max) Dt = t_max - t
      endif
   endassociate
   endfunction compute_dt

   ! ADT integrand deferred methods
   function dAdvection_dt(self, t) result(dState_dt)
   !< Time derivative of advection field, the residuals function.
   class(linear_advection_object), intent(in)           :: self                         !< Advection field.
   real(R_P),                      intent(in), optional :: t                            !< Time.
   class(integrand), allocatable                        :: dState_dt                    !< Advection field time derivative.
   real(R_P)                                            :: u(1-self%Ng:self%Ni+self%Ng) !< Conservative variable.
   real(R_P)                                            :: ur(1:2,0:self%Ni+1)          !< Reconstructed conservative variable.
   real(R_P)                                            :: f(0:self%Ni)                 !< Flux of conservative variable.
   integer(I_P)                                         :: i                            !< Counter.

   do i=1, self%Ni
      U(i) = self%U(i)
   enddo
   call self%impose_boundary_conditions(u=u)
   call self%reconstruct_interfaces(conservative=u, r_conservative=ur)
   do i=0, self%Ni
      call solve_riemann_problem(state_left=ur(2, i), state_right=ur(1, i+1), flux=f(i))
   enddo
   allocate(linear_advection_object :: dState_dt)
   select type(dState_dt)
   class is(linear_advection_object)
      dState_dt = self
      do i=1, self%Ni
          dState_dt%u(i) = (f(i - 1) - f(i)) / self%Dx
      enddo
   endselect

   contains
      subroutine solve_riemann_problem(state_left, state_right, flux)
      !< Solver Riemann problem of linear advection by upwinding.
      real(R_P), intent(in)  :: state_left  !< Left state.
      real(R_P), intent(in)  :: state_right !< right state.
      real(R_P), intent(out) :: flux        !< Flux of conservative variable.

      if (self%a > 0._R_P) then
         flux = self%a * state_left
      else
         flux = self%a * state_right
      endif
      endsubroutine solve_riemann_problem
   endfunction dAdvection_dt

  function advection_local_error(lhs, rhs) result(error)
  !< Estimate local truncation error between 2 advection approximations.
  !<
  !< The estimation is done by norm L2 of U:
  !<
  !< $$ error = \sqrt{ \sum_i{\sum_i{ \frac{(lhs\%u_i - rhs\%u_i)^2}{lhs\%u_i^2} }} } $$
  class(linear_advection_object), intent(in) :: lhs   !< Left hand side.
  class(integrand),               intent(in) :: rhs   !< Right hand side.
  real(R_P)                                  :: error !< Error estimation.
  integer(I_P)                               :: i     !< Space counter.

  select type(rhs)
  class is (linear_advection_object)
     error = 0._R_P
     do i=1, lhs%Ni
        error = error + (lhs%u(i) - rhs%u(i)) ** 2 / lhs%u(i) ** 2
     enddo
     error = sqrt(error)
  endselect
  endfunction advection_local_error

  function advection_multiply_advection(lhs, rhs) result(opr)
  !< Multiply an advection field by another one.
  class(linear_advection_object), intent(in) :: lhs !< Left hand side.
  class(integrand),               intent(in) :: rhs !< Right hand side.
  class(integrand), allocatable              :: opr !< Operator result.
  integer(I_P)                               :: i   !< Counter.

  allocate(linear_advection_object :: opr)
  select type(opr)
  class is(linear_advection_object)
     opr = lhs
     select type(rhs)
     class is (linear_advection_object)
        do i=1, lhs%Ni
           opr%u(i) = lhs%u(i) * rhs%u(i)
        enddo
     endselect
  endselect
  endfunction advection_multiply_advection

  function advection_multiply_real(lhs, rhs) result(opr)
  !< Multiply an advection field by a real scalar.
  class(linear_advection_object), intent(in) :: lhs !< Left hand side.
  real(R_P),                      intent(in) :: rhs !< Right hand side.
  class(integrand), allocatable              :: opr !< Operator result.
  integer(I_P)                               :: i   !< Counter.

  allocate(linear_advection_object :: opr)
  select type(opr)
  class is(linear_advection_object)
     opr = lhs
     do i=1, lhs%Ni
        opr%u(i) = rhs * lhs%u(i)
     enddo
  endselect
  endfunction advection_multiply_real

  function real_multiply_advection(lhs, rhs) result(opr)
  !< Multiply a real scalar by an advection field.
  real(R_P),                      intent(in) :: lhs !< Left hand side.
  class(linear_advection_object), intent(in) :: rhs !< Right hand side.
  class(integrand), allocatable              :: opr !< Operator result.
  integer(I_P)                               :: i   !< Counter.

  allocate(linear_advection_object :: opr)
  select type(opr)
  class is(linear_advection_object)
     opr = rhs
     do i=1, rhs%Ni
        opr%u(i) = lhs * rhs%u(i)
     enddo
  endselect
  endfunction real_multiply_advection

  function add_advection(lhs, rhs) result(opr)
  !< Add two advection fields.
  class(linear_advection_object), intent(in) :: lhs !< Left hand side.
  class(integrand),               intent(in) :: rhs !< Right hand side.
  class(integrand), allocatable              :: opr !< Operator result.
  integer(I_P)                               :: i   !< Counter.

  allocate (linear_advection_object :: opr)
  select type(opr)
  class is(linear_advection_object)
     opr = lhs
     select type(rhs)
     class is (linear_advection_object)
        do i=1, lhs%Ni
           opr%u(i) = lhs%u(i) + rhs%u(i)
        enddo
     endselect
  endselect
  endfunction add_advection

  function sub_advection(lhs, rhs) result(opr)
  !< Subtract two advection fields.
  class(linear_advection_object), intent(in) :: lhs !< Left hand side.
  class(integrand),               intent(in) :: rhs !< Right hand side.
  class(integrand), allocatable              :: opr !< Operator result.
  integer(I_P)                               :: i   !< Counter.

  allocate (linear_advection_object :: opr)
  select type(opr)
  class is(linear_advection_object)
     opr = lhs
     select type(rhs)
     class is (linear_advection_object)
        do i=1, lhs%Ni
           opr%u(i) = lhs%u(i) - rhs%u(i)
        enddo
     endselect
  endselect
  endfunction sub_advection

  subroutine advection_assign_advection(lhs, rhs)
  !< Assign one advection field to another.
  class(linear_advection_object), intent(inout) :: lhs !< Left hand side.
  class(integrand),               intent(in)    :: rhs !< Right hand side.
  integer(I_P)                                  :: i   !< Counter.

  select type(rhs)
  class is(linear_advection_object)
     lhs%weno_order = rhs%weno_order
     lhs%Ni         = rhs%Ni
     lhs%Ng         = rhs%Ng
     lhs%Dx         = rhs%Dx
     lhs%a          = rhs%a
     if (allocated(rhs%u)) then
        if (allocated(lhs%u)) deallocate(lhs%u) ; allocate(lhs%u(1:lhs%Ni))
        select type(rhs)
        class is(linear_advection_object)
           if (allocated(rhs%U)) then
              do i=1, lhs%Ni
                 lhs%u(i) = rhs%u(i)
              enddo
           endif
        endselect
     endif
     if (allocated(rhs%BC_L)) lhs%BC_L = rhs%BC_L
     if (allocated(rhs%BC_R)) lhs%BC_R = rhs%BC_R
     if (allocated(rhs%interpolator)) then
        if (allocated(lhs%interpolator)) deallocate(lhs%interpolator)
        allocate(lhs%interpolator, mold=rhs%interpolator)
        lhs%interpolator = rhs%interpolator
     endif
  endselect
  endsubroutine advection_assign_advection

  subroutine advection_assign_real(lhs, rhs)
  !< Assign one real to an advection field.
  class(linear_advection_object), intent(inout) :: lhs !< Left hand side.
  real(R_P),                      intent(in)    :: rhs !< Right hand side.
  integer(I_P)                                  :: i   !< Counter.

  if (allocated(lhs%u)) then
     do i=1, lhs%Ni
        lhs%u(i) = rhs
     enddo
  endif
  endsubroutine advection_assign_real

   ! private methods
   pure subroutine impose_boundary_conditions(self, u)
   !< Impose boundary conditions.
   class(linear_advection_object), intent(in)    :: self          !< Advection field.
   real(R_P),                      intent(inout) :: u(1-self%Ng:) !< Conservative variables.
   integer(I_P)                                  :: i             !< Space counter.

   select case(trim(adjustl(self%BC_L)))
      case('TRA') ! trasmissive (non reflective) BC
         do i=1-self%Ng, 0
            u(i) = u(-i+1)
         enddo
      case('REF') ! reflective BC
         do i=1-self%Ng, 0
            u(i) = - u(-i+1)
         enddo
      case('PER') ! periodic BC
         do i=1-self%Ng, 0
            u(i) = u(self%Ni+i)
         enddo
   endselect

   select case(trim(adjustl(self%BC_R)))
      case('TRA') ! trasmissive (non reflective) BC
         do i=self%Ni+1, self%Ni+self%Ng
            u(i) = u(self%Ni-(i-self%Ni-1))
         enddo
      case('REF') ! reflective BC
         do i=self%Ni+1, self%Ni+self%Ng
            u(i) = - u(self%Ni-(i-self%Ni-1))
         enddo
      case('PER') ! periodic BC
         do i=self%Ni+1, self%Ni+self%Ng
            u(i) = u(i-self%Ni)
         enddo
   endselect
   endsubroutine impose_boundary_conditions

   subroutine reconstruct_interfaces(self, conservative, r_conservative)
   !< Reconstruct interfaces states.
   class(linear_advection_object), intent(in)    :: self                         !< Advection field.
   real(R_P),                      intent(in)    :: conservative(1-self%Ng:)     !< Conservative variables.
   real(R_P),                      intent(inout) :: r_conservative(1:, 0:)       !< Reconstructed conservative vars.
   real(R_P), allocatable                        :: U(:)                         !< Serialized conservative variables.
   real(R_P)                                     :: C(1:2, 1-self%Ng:-1+self%Ng) !< Stencils.
   real(R_P)                                     :: CR(1:2)                      !< Reconstrcuted intrafaces.
   integer(I_P)                                  :: i                            !< Counter.
   integer(I_P)                                  :: j                            !< Counter.
   integer(I_P)                                  :: f                            !< Counter.

   select case(self%weno_order)
   case(1) ! 1st order piecewise constant reconstruction
      do i=0, self%Ni+1
         r_conservative(1, i) = conservative(i)
         r_conservative(2, i) = r_conservative(1, i)
      enddo
   case(3, 5, 7, 9, 11, 13, 15, 17) ! 3rd-17th order WENO reconstruction
      do i=0, self%Ni+1
         do j=i+1-self%Ng, i-1+self%Ng
            do f=1, 2
               C(f, j-i) = conservative(j)
            enddo
         enddo
         call self%interpolator%interpolate(stencil=C(:, :), interpolation=CR(:))
         do f=1, 2
            r_conservative(f, i)  = CR(f)
         enddo
      enddo
   endselect
   endsubroutine reconstruct_interfaces
endmodule wenoof_test_linear_advection_object

program wenoof_test_linear_advection
!< WenOOF test: 1D linear advection.

use flap, only : command_line_interface
use foodie, only : integrator_runge_kutta_lssp, integrator_runge_kutta_ssp
use wenoof_test_linear_advection_object, only : linear_advection_object
use penf, only : cton, FR_P, I_P, R_P, str

implicit none
character(len=99)                          :: s_scheme                   !< Space scheme.
character(len=99)                          :: t_scheme                   !< Time scheme.
integer(I_P)                               :: weno_order                 !< WENO reconstruction order.
real(R_P)                                  :: weno_eps                   !< WENO epsilon value.
integer(I_P)                               :: stages                     !< Number of stages.
type(integrator_runge_kutta_lssp)          :: rk_integrator              !< Runge-Kutta integrator.
type(integrator_runge_kutta_ssp)           :: rk_integrator_s            !< Runge-Kutta integrator.
type(linear_advection_object), allocatable :: rk_stage(:)                !< Runge-Kutta stages.
real(R_P)                                  :: dt                         !< Time step.
real(R_P)                                  :: t                          !< Time.
integer(I_P)                               :: step                       !< Time steps counter.
type(linear_advection_object)              :: domain                     !< Domain of Advection equations.
real(R_P)                                  :: CFL                        !< CFL value.
character(3)                               :: BC_L                       !< Left boundary condition type.
character(3)                               :: BC_R                       !< Right boundary condition type.
integer(I_P)                               :: Ni                         !< Number of grid cells.
real(R_P)                                  :: Dx                         !< Space step discretization.
real(R_P)                                  :: a                          !< Advection coefficient.
real(R_P), allocatable                     :: x(:)                       !< Cell center x-abscissa values.
integer(I_P)                               :: steps_max                  !< Maximum number of time steps.
real(R_P)                                  :: t_max                      !< Maximum integration time.
logical                                    :: results                    !< Flag for activating results saving.
logical                                    :: time_serie                 !< Flag for activating time serie-results saving.
logical                                    :: verbose                    !< Flag for activating more verbose output.
real(R_P), parameter                       :: pi = 4._R_P * atan(1._R_P) !< Pi greek.

call parse_command_line_interface
if (verbose) print "(A)", 'Solve 1D linear advection equation " u_t + (a*u)_x =0" with a='//trim(str(a))
call initialize
call save_time_serie(filename='linear_advection-'//                                                      &
                              trim(adjustl(s_scheme))//'-'//trim(str(weno_order, no_sign=.true.))//'-'// &
                              trim(adjustl(t_scheme))//'-'//trim(str(stages, no_sign=.true.))//'-'//     &
                              'Ni_'//trim(str(Ni, no_sign=.true.))//'.dat', t=t)
step = 0
time_loop: do
   step = step + 1
   dt = domain%dt(steps_max=steps_max, t_max=t_max, t=t, CFL=CFL)
   if (trim(adjustl(t_scheme))=='runge_kutta_ssp_stages_5_order_4') then
      call rk_integrator_s%integrate(U=domain, stage=rk_stage, dt=dt, t=t)
   else
      call rk_integrator%integrate(U=domain, stage=rk_stage, dt=dt, t=t)
   endif
   t = t + dt
   call save_time_serie(t=t)
   if (verbose) print "(A)", 'step = '//str(n=step)//', time step = '//str(n=dt)//', time = '//str(n=t)
   if ((t == t_max).or.(step == steps_max)) exit time_loop
enddo time_loop
call save_time_serie(t=t, finish=.true.)

contains
   subroutine initialize()
   !< Initialize the test.
   real(R_P),   allocatable :: initial_state(:) !< Initial state of primitive variables.
   integer(I_P)             :: i                !< Space counter.

   if (trim(adjustl(t_scheme))=='runge_kutta_ssp_stages_5_order_4') then
      call rk_integrator_s%initialize(scheme=t_scheme, stop_on_fail=.true.)
      if (allocated(rk_stage)) deallocate(rk_stage) ; allocate(rk_stage(1:rk_integrator_s%stages))
   else
      call rk_integrator%initialize(scheme=t_scheme, stages=stages)
      if (allocated(rk_stage)) deallocate(rk_stage) ; allocate(rk_stage(1:rk_integrator%stages))
   endif
   t = 0._R_P
   if (allocated(x)) deallocate(x) ; allocate(x(1:Ni))
   if (allocated(initial_state)) deallocate(initial_state) ; allocate(initial_state(1:Ni))
   Dx = 1._R_P / Ni
   call square_wave_initial_state(initial_state=initial_state)
   call domain%initialize(Ni=Ni, Dx=Dx,                &
                          BC_L=BC_L, BC_R=BC_R,        &
                          initial_state=initial_state, &
                          s_scheme=s_scheme,           &
                          a=a,                         &
                          weno_order=weno_order)
   endsubroutine initialize

   subroutine parse_command_line_interface()
   !< Parse Command Line Interface (CLI).
   type(command_line_interface)  :: cli    !< Command line interface handler.
   integer(I_P)                  :: error  !< Error handler.
   character(len=:), allocatable :: buffer !< String buffer.

   call cli%init(description = 'WenOOF test: 1D linear advection equation', &
                 examples    = ["wenoof_test_linear_advection         ",    &
                                "wenoof_test_linear_advection --tserie"])
   call cli%add(switch='-a', help='advection coefficient', required=.false., act='store', def='1.0')
   call cli%add(switch='--Ni', help='number finite volumes used', required=.false., act='store', def='100')
   call cli%add(switch='--steps', help='number time steps performed', required=.false., act='store', def='100')
   call cli%add(switch='--t-max', help='maximum integration time', required=.false., act='store', def='0.')
   call cli%add(switch='--s-scheme', help='space intergation scheme', required=.false., act='store', def='reconstructor-JS', &
     choices='reconstructor-JS,reconstructor-M-JS,reconstructor-M-Z,reconstructor-Z')
   call cli%add(switch='--weno-order', help='WENO order', required=.false., act='store', def='1')
   call cli%add(switch='--weno-eps', help='WENO epsilon parameter', required=.false., act='store', def='0.000001')
   call cli%add(switch='--t-scheme', help='time intergation scheme', required=.false., act='store', &
                def='runge_kutta_lssp_stages_s_order_s_1',                                          &
                choices='runge_kutta_lssp_stages_s_order_s_1,runge_kutta_lssp_stages_s_order_s,runge_kutta_ssp_stages_5_order_4')
   call cli%add(switch='--stages', help='number stages', required=.false., act='store', def='2')
   call cli%add(switch='--cfl', help='CFL value', required=.false., act='store', def='0.8')
   call cli%add(switch='--tserie', switch_ab='-t', help='Save time-serie-result', required=.false., act='store_true', def='.false.')
   call cli%add(switch='--verbose', help='Verbose output', required=.false., act='store_true', def='.false.')
   call cli%parse(error=error)
   call cli%get(switch='-a',           val=a,          error=error) ; if (error/=0) stop
   call cli%get(switch='--Ni',         val=Ni,         error=error) ; if (error/=0) stop
   call cli%get(switch='--steps',      val=steps_max,  error=error) ; if (error/=0) stop
   call cli%get(switch='--t-max',      val=t_max,      error=error) ; if (error/=0) stop
   call cli%get(switch='--s-scheme',   val=s_scheme,   error=error) ; if (error/=0) stop
   call cli%get(switch='--weno-order', val=weno_order, error=error) ; if (error/=0) stop
   call cli%get(switch='--weno-eps',   val=weno_eps,   error=error) ; if (error/=0) stop
   call cli%get(switch='--t-scheme',   val=t_scheme,   error=error) ; if (error/=0) stop
   call cli%get(switch='--stages',     val=stages,     error=error) ; if (error/=0) stop
   call cli%get(switch='--cfl',        val=CFL,        error=error) ; if (error/=0) stop
   call cli%get(switch='--tserie',     val=time_serie, error=error) ; if (error/=0) stop
   call cli%get(switch='--verbose',    val=verbose,    error=error) ; if (error/=0) stop

   if (t_max > 0._R_P) steps_max = 0
   endsubroutine parse_command_line_interface

   subroutine square_wave_initial_state(initial_state)
   real(R_P),   intent(inout) :: initial_state(1:) !< Initial state of primitive variables.
   integer(I_P)               :: i                 !< Space counter.

   BC_L = 'PER'
   BC_R = 'PER'
   do i=1, Ni
      x(i) = Dx * i - 0.5_R_P * Dx
      if     (x(i) < 0.25_R_P) then
         initial_state(i) = 0._R_P
      elseif (0.25_R_P <= x(i) .and. x(i) < 0.75_R_P) then
         initial_state(i) = 1._R_P
      else
         initial_state(i) = 0._R_P
      endif
   enddo
   endsubroutine square_wave_initial_state

   subroutine save_time_serie(t, filename, finish)
   !< Save time-serie results.
   real(R_P),    intent(in)           :: t         !< Current integration time.
   character(*), intent(in), optional :: filename  !< Output filename.
   logical,      intent(in), optional :: finish    !< Flag for triggering the file closing.
   integer(I_P), save                 :: tsfile    !< File unit for saving time serie results.
   integer(I_P)                       :: i         !< Counter.

   if (time_serie) then
      if (present(filename)) then
         open(newunit=tsfile, file=filename)
      endif
      write(tsfile, '(A)')'VARIABLES = "x" "u"'
      write(tsfile, '(A)')'ZONE T="'//str(n=t)//'"'
      do i=1, Ni
         write(tsfile, '(4'//'('//FR_P//',1X))')x(i), domain%u(i)
      enddo
      if (present(finish)) then
         if (finish) close(tsfile)
      endif
   endif
   endsubroutine save_time_serie
endprogram wenoof_test_linear_advection


!*==dsytrd_sy2sb.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DSYTRD_SY2SB
!
!  @generated from zhetrd_he2hb.f, fortran z -> d, Wed Dec  7 08:22:39 2016
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DSYTRD_SY2SB + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DSYTRD_SY2SB( UPLO, N, KD, A, LDA, AB, LDAB, TAU,
!                              WORK, LWORK, INFO )
!
!       IMPLICIT NONE
!
!       .. Scalar Arguments ..
!       CHARACTER          UPLO
!       INTEGER            INFO, LDA, LDAB, LWORK, N, KD
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   A( LDA, * ), AB( LDAB, * ),
!                          TAU( * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DSYTRD_SY2SB reduces a real symmetric matrix A to real symmetric
!> band-diagonal form AB by a orthogonal similarity transformation:
!> Q**T * A * Q = AB.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>          = 'U':  Upper triangle of A is stored;
!>          = 'L':  Lower triangle of A is stored.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in] KD
!> \verbatim
!>          KD is INTEGER
!>          The number of superdiagonals of the reduced matrix if UPLO = 'U',
!>          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
!>          The reduced matrix is stored in the array AB.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
!>          N-by-N upper triangular part of A contains the upper
!>          triangular part of the matrix A, and the strictly lower
!>          triangular part of A is not referenced.  If UPLO = 'L', the
!>          leading N-by-N lower triangular part of A contains the lower
!>          triangular part of the matrix A, and the strictly upper
!>          triangular part of A is not referenced.
!>          On exit, if UPLO = 'U', the diagonal and first superdiagonal
!>          of A are overwritten by the corresponding elements of the
!>          tridiagonal matrix T, and the elements above the first
!>          superdiagonal, with the array TAU, represent the orthogonal
!>          matrix Q as a product of elementary reflectors; if UPLO
!>          = 'L', the diagonal and first subdiagonal of A are over-
!>          written by the corresponding elements of the tridiagonal
!>          matrix T, and the elements below the first subdiagonal, with
!>          the array TAU, represent the orthogonal matrix Q as a product
!>          of elementary reflectors. See Further Details.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!> \endverbatim
!>
!> \param[out] AB
!> \verbatim
!>          AB is DOUBLE PRECISION array, dimension (LDAB,N)
!>          On exit, the upper or lower triangle of the symmetric band
!>          matrix A, stored in the first KD+1 rows of the array.  The
!>          j-th column of A is stored in the j-th column of the array AB
!>          as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!> \endverbatim
!>
!> \param[in] LDAB
!> \verbatim
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!> \endverbatim
!>
!> \param[out] TAU
!> \verbatim
!>          TAU is DOUBLE PRECISION array, dimension (N-KD)
!>          The scalar factors of the elementary reflectors (see Further
!>          Details).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>          On exit, if INFO = 0, or if LWORK=-1,
!>          WORK(1) returns the size of LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK which should be calculated
!>          by a workspace query. LWORK = MAX(1, LWORK_QUERY)
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!>          LWORK_QUERY = N*KD + N*max(KD,FACTOPTNB) + 2*KD*KD
!>          where FACTOPTNB is the blocking used by the QR or LQ
!>          algorithm, usually FACTOPTNB=128 is a good choice otherwise
!>          putting LWORK=-1 will provide the size of WORK.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date November 2017
!
!> \ingroup doubleSYcomputational
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Implemented by Azzam Haidar.
!>
!>  All details are available on technical report, SC11, SC13 papers.
!>
!>  Azzam Haidar, Hatem Ltaief, and Jack Dongarra.
!>  Parallel reduction to condensed forms for symmetric eigenvalue problems
!>  using aggregated fine-grained and memory-aware kernels. In Proceedings
!>  of 2011 International Conference for High Performance Computing,
!>  Networking, Storage and Analysis (SC '11), New York, NY, USA,
!>  Article 8 , 11 pages.
!>  http://doi.acm.org/10.1145/2063384.2063394
!>
!>  A. Haidar, J. Kurzak, P. Luszczek, 2013.
!>  An improved parallel singular value algorithm and its implementation
!>  for multicore hardware, In Proceedings of 2013 International Conference
!>  for High Performance Computing, Networking, Storage and Analysis (SC '13).
!>  Denver, Colorado, USA, 2013.
!>  Article 90, 12 pages.
!>  http://doi.acm.org/10.1145/2503210.2503292
!>
!>  A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra.
!>  A novel hybrid CPU-GPU generalized eigensolver for electronic structure
!>  calculations based on fine-grained memory aware tasks.
!>  International Journal of High Performance Computing Applications.
!>  Volume 28 Issue 2, Pages 196-209, May 2014.
!>  http://hpc.sagepub.com/content/28/2/196
!>
!> \endverbatim
!>
!> \verbatim
!>
!>  If UPLO = 'U', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(k)**T . . . H(2)**T H(1)**T, where k = n-kd.
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(1:i+kd-1) = 0 and v(i+kd) = 1; conjg(v(i+kd+1:n)) is stored on exit in
!>  A(i,i+kd+1:n), and tau in TAU(i).
!>
!>  If UPLO = 'L', the matrix Q is represented as a product of elementary
!>  reflectors
!>
!>     Q = H(1) H(2) . . . H(k), where k = n-kd.
!>
!>  Each H(i) has the form
!>
!>     H(i) = I - tau * v * v**T
!>
!>  where tau is a real scalar, and v is a real vector with
!>  v(kd+1:i) = 0 and v(i+kd+1) = 1; v(i+kd+2:n) is stored on exit in
!>  A(i+kd+2:n,i), and tau in TAU(i).
!>
!>  The contents of A on exit are illustrated by the following examples
!>  with n = 5:
!>
!>  if UPLO = 'U':                       if UPLO = 'L':
!>
!>    (  ab  ab/v1  v1      v1     v1    )              (  ab                            )
!>    (      ab     ab/v2   v2     v2    )              (  ab/v1  ab                     )
!>    (             ab      ab/v3  v3    )              (  v1     ab/v2  ab              )
!>    (                     ab     ab/v4 )              (  v1     v2     ab/v3  ab       )
!>    (                            ab    )              (  v1     v2     v3     ab/v4 ab )
!>
!>  where d and e denote diagonal and off-diagonal elements of T, and vi
!>  denotes an element of the vector defining H(i).
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE DSYTRD_SY2SB(Uplo,N,Kd,A,Lda,Ab,Ldab,Tau,Work,Lwork,   &
     &                        Info)
!
      IMPLICIT NONE
!*--DSYTRD_SY2SB248
!
!  -- LAPACK computational routine (version 3.8.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     November 2017
!
!     .. Scalar Arguments ..
      CHARACTER Uplo
      INTEGER Info , Lda , Ldab , Lwork , N , Kd
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION A(Lda,*) , Ab(Ldab,*) , Tau(*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION RONE
      DOUBLE PRECISION ZERO , ONE , HALF
      PARAMETER (RONE=1.0D+0,ZERO=0.0D+0,ONE=1.0D+0,HALF=0.5D+0)
!     ..
!     .. Local Scalars ..
      LOGICAL lquery , upper
      INTEGER i , j , iinfo , lwmin , pn , pk , lk , ldt , ldw , lds2 , &
     &        lds1 , ls2 , ls1 , lw , lt , tpos , wpos , s2pos , s1pos
!     ..
!     .. External Subroutines ..
      EXTERNAL XERBLA , DSYR2K , DSYMM , DGEMM , DCOPY , DLARFT ,       &
     &         DGELQF , DGEQRF , DLASET
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MIN , MAX
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ILAENV2STAGE
      EXTERNAL LSAME , ILAENV2STAGE
!     ..
!     .. Executable Statements ..
!
!     Determine the minimal workspace size required
!     and test the input parameters
!
      Info = 0
      upper = LSAME(Uplo,'U')
      lquery = (Lwork==-1)
      lwmin = ILAENV2STAGE(4,'DSYTRD_SY2SB','',N,Kd,-1,-1)

      IF ( .NOT.upper .AND. .NOT.LSAME(Uplo,'L') ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Kd<0 ) THEN
         Info = -3
      ELSEIF ( Lda<MAX(1,N) ) THEN
         Info = -5
      ELSEIF ( Ldab<MAX(1,Kd+1) ) THEN
         Info = -7
      ELSEIF ( Lwork<lwmin .AND. .NOT.lquery ) THEN
         Info = -10
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('DSYTRD_SY2SB',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         Work(1) = lwmin
         RETURN
      ENDIF
!
!     Quick return if possible
!     Copy the upper/lower portion of A into AB
!
      IF ( N<=Kd+1 ) THEN
         IF ( upper ) THEN
            DO i = 1 , N
               lk = MIN(Kd+1,i)
               CALL DCOPY(lk,A(i-lk+1,i),1,Ab(Kd+1-lk+1,i),1)
            ENDDO
         ELSE
            DO i = 1 , N
               lk = MIN(Kd+1,N-i+1)
               CALL DCOPY(lk,A(i,i),1,Ab(1,i),1)
            ENDDO
         ENDIF
         Work(1) = 1
         RETURN
      ENDIF
!
!     Determine the pointer position for the workspace
!
      ldt = Kd
      lds1 = Kd
      lt = ldt*Kd
      lw = N*Kd
      ls1 = lds1*Kd
      ls2 = lwmin - lt - lw - ls1
!      LS2 = N*MAX(KD,FACTOPTNB)
      tpos = 1
      wpos = tpos + lt
      s1pos = wpos + lw
      s2pos = s1pos + ls1
      IF ( upper ) THEN
         ldw = Kd
         lds2 = Kd
      ELSE
         ldw = N
         lds2 = N
      ENDIF
!
!
!     Set the workspace of the triangular matrix T to zero once such a
!     way every time T is generated the upper/lower portion will be always zero
!
      CALL DLASET("A",ldt,Kd,ZERO,ZERO,Work(tpos),ldt)
!
      IF ( upper ) THEN
         DO i = 1 , N - Kd , Kd
            pn = N - i - Kd + 1
            pk = MIN(N-i-Kd+1,Kd)
!
!            Compute the LQ factorization of the current block
!
            CALL DGELQF(Kd,pn,A(i,i+Kd),Lda,Tau(i),Work(s2pos),ls2,     &
     &                  iinfo)
!
!            Copy the upper portion of A into AB
!
            DO j = i , i + pk - 1
               lk = MIN(Kd,N-j) + 1
               CALL DCOPY(lk,A(j,j),Lda,Ab(Kd+1,j),Ldab-1)
            ENDDO
!
            CALL DLASET('Lower',pk,pk,ZERO,ONE,A(i,i+Kd),Lda)
!
!            Form the matrix T
!
            CALL DLARFT('Forward','Rowwise',pn,pk,A(i,i+Kd),Lda,Tau(i), &
     &                  Work(tpos),ldt)
!
!            Compute W:
!
            CALL DGEMM('Conjugate','No transpose',pk,pn,pk,ONE,         &
     &                 Work(tpos),ldt,A(i,i+Kd),Lda,ZERO,Work(s2pos),   &
     &                 lds2)
!
            CALL DSYMM('Right',Uplo,pk,pn,ONE,A(i+Kd,i+Kd),Lda,         &
     &                 Work(s2pos),lds2,ZERO,Work(wpos),ldw)
!
            CALL DGEMM('No transpose','Conjugate',pk,pk,pn,ONE,         &
     &                 Work(wpos),ldw,Work(s2pos),lds2,ZERO,Work(s1pos),&
     &                 lds1)
!
            CALL DGEMM('No transpose','No transpose',pk,pn,pk,-HALF,    &
     &                 Work(s1pos),lds1,A(i,i+Kd),Lda,ONE,Work(wpos),   &
     &                 ldw)
!
!
!            Update the unreduced submatrix A(i+kd:n,i+kd:n), using
!            an update of the form:  A := A - V'*W - W'*V
!
            CALL DSYR2K(Uplo,'Conjugate',pn,pk,-ONE,A(i,i+Kd),Lda,      &
     &                  Work(wpos),ldw,RONE,A(i+Kd,i+Kd),Lda)
         ENDDO
!
!        Copy the upper band to AB which is the band storage matrix
!
         DO j = N - Kd + 1 , N
            lk = MIN(Kd,N-j) + 1
            CALL DCOPY(lk,A(j,j),Lda,Ab(Kd+1,j),Ldab-1)
         ENDDO
!
      ELSE
!
!         Reduce the lower triangle of A to lower band matrix
!
         DO i = 1 , N - Kd , Kd
            pn = N - i - Kd + 1
            pk = MIN(N-i-Kd+1,Kd)
!
!            Compute the QR factorization of the current block
!
            CALL DGEQRF(pn,Kd,A(i+Kd,i),Lda,Tau(i),Work(s2pos),ls2,     &
     &                  iinfo)
!
!            Copy the upper portion of A into AB
!
            DO j = i , i + pk - 1
               lk = MIN(Kd,N-j) + 1
               CALL DCOPY(lk,A(j,j),1,Ab(1,j),1)
            ENDDO
!
            CALL DLASET('Upper',pk,pk,ZERO,ONE,A(i+Kd,i),Lda)
!
!            Form the matrix T
!
            CALL DLARFT('Forward','Columnwise',pn,pk,A(i+Kd,i),Lda,     &
     &                  Tau(i),Work(tpos),ldt)
!
!            Compute W:
!
            CALL DGEMM('No transpose','No transpose',pn,pk,pk,ONE,      &
     &                 A(i+Kd,i),Lda,Work(tpos),ldt,ZERO,Work(s2pos),   &
     &                 lds2)
!
            CALL DSYMM('Left',Uplo,pn,pk,ONE,A(i+Kd,i+Kd),Lda,          &
     &                 Work(s2pos),lds2,ZERO,Work(wpos),ldw)
!
            CALL DGEMM('Conjugate','No transpose',pk,pk,pn,ONE,         &
     &                 Work(s2pos),lds2,Work(wpos),ldw,ZERO,Work(s1pos),&
     &                 lds1)
!
            CALL DGEMM('No transpose','No transpose',pn,pk,pk,-HALF,    &
     &                 A(i+Kd,i),Lda,Work(s1pos),lds1,ONE,Work(wpos),   &
     &                 ldw)
!
!
!            Update the unreduced submatrix A(i+kd:n,i+kd:n), using
!            an update of the form:  A := A - V*W' - W*V'
!
            CALL DSYR2K(Uplo,'No transpose',pn,pk,-ONE,A(i+Kd,i),Lda,   &
     &                  Work(wpos),ldw,RONE,A(i+Kd,i+Kd),Lda)
!            ==================================================================
!            RESTORE A FOR COMPARISON AND CHECKING TO BE REMOVED
!             DO 45 J = I, I+PK-1
!                LK = MIN( KD, N-J ) + 1
!                CALL DCOPY( LK, AB( 1, J ), 1, A( J, J ), 1 )
!   45        CONTINUE
!            ==================================================================
         ENDDO
!
!        Copy the lower band to AB which is the band storage matrix
!
         DO j = N - Kd + 1 , N
            lk = MIN(Kd,N-j) + 1
            CALL DCOPY(lk,A(j,j),1,Ab(1,j),1)
         ENDDO

      ENDIF
!
      Work(1) = lwmin
!
!     End of DSYTRD_SY2SB
!
      END SUBROUTINE DSYTRD_SY2SB


      module genshp_m
c
c----------------------------------------
c    aims to generate the shape function
c    specially for DG interface elements
c----------------------------------------
        use global_const_m
        use number_def_m
        use elmpar_m
        use shpdat_m
        use genpar_m
        use blkdat_m
        use intpt_m
c
        implicit none
c
        contains

        subroutine genshpif
     &(            shpif
     &,            shgif
     &)
c
          real*8, dimension(MAXTOP,      maxsh, MAXQPT), intent(out) :: shpif   ! shape function
          real*8, dimension(MAXTOP, nsd, maxsh, MAXQPT), intent(out) :: shgif   ! shape function gradient
c
          integer :: i, iblk, id, itpif
c
c... loop over the interface blocks and
c    generate shape functions and gradients
c
          do iblk = 1, nelblif
c
            nshl0   = lcblkif(iblkif_nshl0,iblk)
            nshl1   = lcblkif(iblkif_nshl1,iblk)
            id      = lcblkif(iblkif_topology,iblk)
c
            do i = 1, nintif(id)
              call shpTet(ipord, Qptif(itp_tet,1:3,i), shpif(itp_tet,:,i), shgif(itp_tet,:,:,i))
              call shp6w (ipord, Qptif(itp_wedge,1:3,i), shpif(itp_wedge,:,i),shgif(itp_wedge,:,:,i))
            enddo
c
            shgif(itp_tet,:,:,1:nintif(id)) =
     &        shgif(itp_tet,:,:,1:nintif(id)) / two
c
          enddo
c
        end subroutine genshpif
c
      end module genshp_m