!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Spherepack                            *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!

submodule(gradient_routines) gradient_gaussian_grid

contains

    !     subroutine gradgc(nlat, nlon, isym, nt, v, w, idvw, jdvw, a, b, mdab, ndab, &
    !                       wvhsgc, ierror)
    !
    !     given the scalar spherical harmonic coefficients a and b, precomputed
    !     by subroutine shagc for a scalar field sf, subroutine gradgc computes
    !     an irrotational vector field (v, w) such that
    !
    !           gradient(sf) = (v, w).
    !
    !     v is the colatitudinal and w is the east longitudinal component
    !     of the gradient.  i.e.,
    !
    !            v(i, j) = d(sf(i, j))/dtheta
    !
    !     and
    !
    !            w(i, j) = 1/sint*d(sf(i, j))/dlambda
    !
    !     at the gaussian colatitude point theta(i) (see nlat as input
    !     parameter) and longitude lambda(j) = (j-1)*2*pi/nlon where
    !     where sint = sin(theta(i)).  required associated legendre polynomials
    !     are recomputed rather than stored as they are in subroutine gradgs. this
    !     saves storage (compare lsav with lsav in gradgs) but increases
    !     computational requirements.
    !
    !
    !     input parameters
    !
    !     nlat   the number of points in the gaussian colatitude grid on the
    !            full sphere. these lie in the interval (0, pi) and are computed
    !            in radians in theta(1) <...< theta(nlat) by subroutine compute_gaussian_latitudes_and_weights.
    !            if nlat is odd the equator will be included as the grid point
    !            theta((nlat + 1)/2).  if nlat is even the equator will be
    !            excluded as a grid point and will lie half way between
    !            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
    !            note: on the half sphere, the number of grid points in the
    !            colatitudinal direction is nlat/2 if nlat is even or
    !            (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct londitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater than
    !            3.  the efficiency of the computation is improved when nlon
    !            is a product of small prime numbers.
    !
    !
    !     isym   this has the same value as the isym that was input to
    !            subroutine shagc to compute the arrays a and b from the
    !            scalar field sf.  isym determines whether (v, w) are
    !            computed on the full or half sphere as follows:
    !
    !      = 0
    !
    !           sf is not symmetric about the equator. in this case
    !           the vector field (v, w) is computed on the entire sphere.
    !           i.e., in the arrays  v(i, j), w(i, j) for i=1, ..., nlat and
    !           j=1, ..., nlon.
    !
    !      = 1
    !
    !           sf is antisymmetric about the equator. in this case w is
    !           antisymmetric and v is symmetric about the equator. w
    !           and v are computed on the northern hemisphere only.  i.e.,
    !           if nlat is odd they are computed for i=1, ..., (nlat + 1)/2
    !           and j=1, ..., nlon.  if nlat is even they are computed for
    !           i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !      = 2
    !
    !           sf is symmetric about the equator. in this case w is
    !           symmetric and v is antisymmetric about the equator. w
    !           and v are computed on the northern hemisphere only.  i.e.,
    !           if nlat is odd they are computed for i=1, ..., (nlat + 1)/2
    !           and j=1, ..., nlon.  if nlat is even they are computed for
    !           i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !
    !     nt     nt is the number of scalar and vector fields.  some
    !            computational efficiency is obtained for multiple fields.
    !            the arrays a, b, v, and w can be three dimensional corresponding
    !            to an indexed multiple array sf.  in this case, multiple
    !            vector synthesis will be performed to compute each vector
    !            field.  the third index for a, b, v, and w is the synthesis
    !            index which assumes the values k = 1, ..., nt.  for a single
    !            synthesis set nt = 1.  the description of the remaining
    !            parameters is simplified by assuming that nt=1 or that a, b, v,
    !            and w are two dimensional arrays.
    !
    !     idvw   the first dimension of the arrays v, w as it appears in
    !            the program that calls gradgc. if isym = 0 then idvw
    !            must be at least nlat.  if isym = 1 or 2 and nlat is
    !            even then idvw must be at least nlat/2. if isym = 1 or 2
    !            and nlat is odd then idvw must be at least (nlat + 1)/2.
    !
    !     jdvw   the second dimension of the arrays v, w as it appears in
    !            the program that calls gradgc. jdvw must be at least nlon.
    !
    !     a, b    two or three dimensional arrays (see input parameter nt)
    !            that contain scalar spherical harmonic coefficients
    !            of the scalar field array sf as computed by subroutine shagc.
    !     ***    a, b must be computed by shagc prior to calling gradgc.
    !
    !     mdab   the first dimension of the arrays a and b as it appears in
    !            the program that calls gradgc (and shagc). mdab must be at
    !            least min(nlat, (nlon+2)/2) if nlon is even or at least
    !            min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !     ndab   the second dimension of the arrays a and b as it appears in
    !            the program that calls gradgc (and shagc). ndab must be at
    !            least nlat.
    !
    !
    !     wvhsgc an array which must be initialized by subroutine vhsgci.
    !            once initialized,
    !            wvhsgc can be used repeatedly by gradgc as long as nlon
    !            and nlat remain unchanged.  wvhsgc must not be altered
    !            between calls of gradgc.
    !
    !
    !     lvhsgc the dimension of the array wvhsgc as it appears in the
    !            program that calls gradgc. Let
    !
    !               l1 = min(nlat, nlon/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2                  if nlat is even or
    !               l2 = (nlat + 1)/2              if nlat is odd
    !
    !            lvhsgc must be at least
    !
    !               4*nlat*l2+3*max(l1-2, 0)*(2*nlat-l1-1)+nlon+15
    !
    !     output parameters
    !
    !
    !     v, w   two or three dimensional arrays (see input parameter nt) that
    !           contain an irrotational vector field such that the gradient of
    !           the scalar field sf is (v, w).  w(i, j) is the east longitude
    !           component and v(i, j) is the colatitudinal component of velocity
    !           at gaussian colatitude and longitude lambda(j) = (j-1)*2*pi/nlon
    !           the indices for v and w are defined at the input parameter
    !           isym.  the vorticity of (v, w) is zero.  note that any nonzero
    !           vector field on the sphere will be multiple valued at the poles
    !           [reference swarztrauber].
    !
    !
    !  ierror   = 0  no errors
    !           = 1  error in the specification of nlat
    !           = 2  error in the specification of nlon
    !           = 3  error in the specification of isym
    !           = 4  error in the specification of nt
    !           = 5  error in the specification of idvw
    !           = 6  error in the specification of jdvw
    !           = 7  error in the specification of mdab
    !           = 8  error in the specification of ndab
    !           = 9  error in the specification of lvhsgc
    !
    module subroutine gradgc(nlat, nlon, isym, nt, v, w, idvw, jdvw, a, b, mdab, ndab, &
        wvhsgc, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: isym
        integer(ip), intent(in)  :: nt
        real(wp),    intent(out) :: v(idvw, jdvw, nt)
        real(wp),    intent(out) :: w(idvw, jdvw, nt)
        integer(ip), intent(in)  :: idvw
        integer(ip), intent(in)  :: jdvw
        real(wp),    intent(in)  :: a(mdab, ndab, nt)
        real(wp),    intent(in)  :: b(mdab, ndab, nt)
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        real(wp),    intent(in)  :: wvhsgc(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip) :: imid, n1, n2, mmax
        integer(ip) :: required_wavetable_size

        ! Check calling arguments
        ierror = 1
        if (nlat < 3) return
        ierror = 2
        if (nlon < 4) return
        ierror = 3
        if (isym < 0 .or. isym > 2) return
        ierror = 4
        if (nt < 0) return
        ierror = 5
        imid = (nlat + 1)/2
        if ((isym == 0 .and. idvw<nlat) .or. &
            (isym /= 0 .and. idvw<imid)) return
        ierror = 6
        if (jdvw < nlon) return
        ierror = 7
        mmax = min(nlat, (nlon + 1)/2)
        if (mdab < min(nlat, (nlon+2)/2)) return
        ierror = 8
        if (ndab < nlat) return
        ierror = 9
        !
        !     verify minimum saved workspace length
        !
        n1 = min(nlat, (nlon + 1)/2)
        n2 = (nlat + 1)/2
        required_wavetable_size =  4*nlat*n2+3*max(n1-2, 0)*(2*nlat-n1-1)+nlon+15
        if (size(wvhsgc) < required_wavetable_size) return
        ierror = 0

        call gradient_lower_utility_routine(nlat, nlon, isym, nt, v, w, idvw, jdvw, a, b, &
            wvhsgc, vhsgc, ierror)

    end subroutine gradgc

end submodule gradient_gaussian_grid


module fcn_monopole
#include <messenger.h>
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO, ONE, TWO, THREE, FOUR, PI, EIGHT
    use type_point,     only: point_t
    use type_function,  only: function_t
    implicit none

    !>  Gaussian function.
    !!
    !!  Three 1D Gaussian functions are computed; one for each dimension. They are multiplied
    !!  together to create a 3D version of the function.
    !!
    !!  \f$  f_x(t,\vec{x}) = a e^{- \frac{(x-b_x)^2}{2c^2} }    \\
    !!       f_y(t,\vec{x}) = a e^{- \frac{(y-b_y)^2}{2c^2} }    \\
    !!       f_z(t,\vec{x}) = a e^{- \frac{(z-b_z)^2}{2c^2} }    \\
    !!       f(t,\vec{x}) = f_x * f_y * f_z                      \f$
    !!
    !!  Function parameters:
    !!
    !!  \f$ a   -   \text{Amplitude of the distribution}   \\
    !!      b_i -   \text{Offset in coordinate 'i'}        \\
    !!      c   -   \text{Width of the distribution}   \f$
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/1/2016
    !!
    !-------------------------------------------------------------------------------------
    type, extends(function_t), public :: monopole_f

    contains

        procedure   :: init
        procedure   :: compute

    end type monopole_f
    !*************************************************************************************

contains

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(monopole_f),  intent(inout)   :: self

        !
        ! Set function name
        !
        call self%set_name("monopole")

        !
        ! Set function options to default settings
        !
        call self%add_option('a',1._rk)

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

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !----------------------------------------------------------------------------------
    impure elemental function compute(self,time,coord) result(val)
        class(monopole_f),  intent(inout)  :: self
        real(rk),           intent(in)  :: time
        type(point_t),      intent(in)  :: coord

        real(rk)                        :: val

        real(rk)    :: x,   y,   z,   r,    &
                       omega, k, q,         &
                       rhobar, cbar, a, Lw, freq

        complex(rk) :: B, imag

        imag = cmplx(ZERO,ONE)

        !
        ! Get inputs and function parameters
        !
        x = coord%c1_
        y = coord%c2_
        z = coord%c3_
        r = sqrt(x*x + y*y + z*z)

        !
        ! Set physical constants
        !
        rhobar = 1.225_rk
        cbar   = 340.25_rk
        Lw     = 0.004819_rk
        freq   = 42.5_rk

        !
        ! Compute monpole amplitude(B) at r
        !
        omega = TWO*PI*freq
        k     = omega/cbar
        q = sqrt(EIGHT*PI*cbar*Lw/(rhobar*((TWO*PI*freq)**TWO)))
        B = imag*rhobar*cbar*q*k/(FOUR*PI*r)

        !
        ! Get indicator to compute 'real' or 'imaginary' component
        !
        a   = self%get_option_value('a')

        if ( a < ONE ) then
            !val = B*cos(-k*r)
            val = real(B*exp(-imag*k*r))
        else if ( a > ONE ) then
            !val = B*sin(-k*r)
            val = aimag(B*exp(-imag*k*r))
        end if

    end function compute
    !***********************************************************************************

end module fcn_monopole


      SUBROUTINE correl(data1,data2,n,ans)
      INTEGER n,NMAX
      REAL data1(n),data2(n)
      COMPLEX ans(n)
      PARAMETER (NMAX=4096)
CU    USES realft,twofft
      INTEGER i,no2
      COMPLEX fft(NMAX)
      call twofft(data1,data2,fft,ans,n)
      no2=n/2
      do 11 i=1,no2+1
        ans(i)=fft(i)*conjg(ans(i))/float(no2)
11    continue
      ans(1)=cmplx(real(ans(1)),real(ans(no2+1)))
      call realft(ans,n,-1)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/correl.for


!   --------------------------------------------------------------------
!   DMET DELUX 2000	Subrutine	spekter             No.:
!   --------------------------------------------------------------------
!   HENSIKT :
!   Beregne JONSWAP-spekter, bølgeamplituder og bølgetall
!
!   METODE :
!   Tar inn frekvens og spekterparametere som signifikant bølgehøyde,
!   midlere periode og toppethetsfaktor (gamma). Benytter disse for
!   å beregne spekterverdier som kan plottes, samt bølgeamplituder
!   og bølgetall for hver enkelt frekvens
!
!   KALLESEKVENS:
!   CALL spekter(a,b,n,pi,omega,sn,zeta_an,k,g,Hs)
!
!   PARAMETERE:
!   Navn	I/O	Type			Innhold/Beskrivelse
!   .......................................................................
!   omega	I	flyttals vektor		bølgefrekvens
!   n		I	heltall			antall frekvensintervaller
!   k		I	flyttalls vektor	bølgetall
!   zeta_an	I	flyttalls vektor	bølgeamplitude
!   hs		I	heltall	  		signifikant bølgehøyde
!   tp		I	heltall			midlere periode
!   gamma	I	heltall			toppethetsfaktor
!   pi		I	flyttall		pi
!   g		I	flyttall		tyngdelfeltsakselerasjon
!   sn		O	flyttall		spekterverdi
!   a		I	heltall			nedre frekvensverdi
!   b		I	heltall			øvre frekvensverdi
!
!   INTERNE VARIABLE:
!   Navn			Funksjon
!   .....................................................................
!   i,m,n			tellevariabler
!   omegap			mellomregningsvariabel
!   konstant,v1,v2,v3		mellomregningsvariabler
!   deltaomega			mellomregningsvariabel
!   sigma			frekvensparameter
!   omegap			frekvensparameter
!
!   SUBRUTINER:
!   Navn			Funksjonsbeskrivelse
!   .....................................................................
!
!
!   LESEFILER:
!   Navn			Eventuell beskrivelse
!   .....................................................................
!   parameter.dat		inneholder spekterinformasjon oppgitt
!
!
!   SKRIVEFILER:
!   Navn			Eventuell beskrivelse
!   .....................................................................
!   spekterplot.dat		skriver frekvens og spekterverdier
!
!
!   --------------------------------------------------------------------
!
!   Programmert av:	     Tor Erik Larsen
!   Dato/Versjon  : 	     27.04.15 / 1.0
!
!   --------------------------------------------------------------------

SUBROUTINE spekter(a,b,n,pi,omega,sn,zeta_an,k,g,Hs)
IMPLICIT NONE

!Erklærer variable
INTEGER::i,m,n
REAL::a,b,tp,gamma,omegap,pi,g,deltaomega,Hs
DOUBLE PRECISION::konstant,v1,v2,v3
DOUBLE PRECISION,DIMENSION(1:n)::omega,sn,sigma,zeta_an,k

!Åpner inndatafil og regner omegap, skriver kontroll til skjerm
OPEN(10,file="parameter.dat")
READ(10,*) hs,tp,gamma,a,b
CLOSE(10)

!Beregner omega-vektor
m = SIZE(omega,1)
DO i=1,m
   omega(i) = a + (b-a)*(i-0.5)/n
END DO

!Beregner omegap
omegap = (2.0*pi)/tp

!Beregner sigma-vektor
do i = 1,n
   if (omegap< omega(i)) then
      sigma(i) = 0.09
   ELSE
      sigma(i) = 0.07
   END IF
END DO

!Faktoriserer Sn
DO i = 1,n
   konstant = (5.0/(32.0*pi))*(hs**2)*tp*(1.0 - 0.287*log(gamma))
   v1 = (omegap/omega(i))**5
   v2 = exp(-(5.0/4.0)*((omegap/omega(i))**4))
   v3 = gamma**(exp(-((omega(i)/omegap)-1.0)**2/(2.0*sigma(i)**2)))
   sn(i)=konstant*v1*v2*v3
END DO

!Beregner amplitudevektor
deltaomega = (b-a)/n
DO i=1,n
   zeta_an(i) = SQRT(2.0*sn(i)*deltaomega)
END DO

!Regner ut vektor for bølgetallet k
DO i=1,n
   k(i)=omega(i)**2 / g
END DO

!Skriver spekteret til fil som kan plottes
OPEN(1010,FILE="spekterplot.dat",ACTION="WRITE",STATUS="UNKNOWN")
DO i=1,n
   WRITE(1010,*) omega(i), sn(i)
END DO
CLOSE(1010)

!Gir tilbake kontrollen og avslutter subrutine
RETURN
END SUBROUTINE


      SUBROUTINE TB01KD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, B,
     $                   LDB, C, LDC, NDIM, U, LDU, WR, WI, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute an additive spectral decomposition of the transfer-
C     function matrix of the system (A,B,C) by reducing the system
C     state-matrix A to a block-diagonal form.
C     The system matrices are transformed as
C     A <-- inv(U)*A*U, B <--inv(U)*B and C <-- C*U.
C     The leading diagonal block of the resulting A has eigenvalues
C     in a suitably defined domain of interest.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the system as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     STDOM   CHARACTER*1
C             Specifies whether the domain of interest is of stability
C             type (left part of complex plane or inside of a circle)
C             or of instability type (right part of complex plane or
C             outside of a circle) as follows:
C             = 'S':  stability type domain;
C             = 'U':  instability type domain.
C
C     JOBA    CHARACTER*1
C             Specifies the shape of the state dynamics matrix on entry
C             as follows:
C             = 'S':  A is in an upper real Schur form;
C             = 'G':  A is a general square dense matrix.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the state-space representation,
C             i.e. the order of the matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs, or of columns of B.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs, or of rows of C.  P >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION.
C             Specifies the boundary of the domain of interest for the
C             eigenvalues of A. For a continuous-time system
C             (DICO = 'C'), ALPHA is the boundary value for the real
C             parts of eigenvalues, while for a discrete-time system
C             (DICO = 'D'), ALPHA >= 0 represents the boundary value for
C             the moduli of eigenvalues.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the unreduced state dynamics matrix A.
C             If JOBA = 'S' then A must be a matrix in real Schur form.
C             On exit, the leading N-by-N part of this array contains a
C             block diagonal matrix inv(U) * A * U with two diagonal
C             blocks in real Schur form with the elements below the
C             first subdiagonal set to zero.
C             The leading NDIM-by-NDIM block of A has eigenvalues in the
C             domain of interest and the trailing (N-NDIM)-by-(N-NDIM)
C             block has eigenvalues outside the domain of interest.
C             The domain of interest for lambda(A), the eigenvalues
C             of A, is defined by the parameters ALPHA, DICO and STDOM
C             as follows:
C             For a continuous-time system (DICO = 'C'):
C               Real(lambda(A)) < ALPHA if STDOM = 'S';
C               Real(lambda(A)) > ALPHA if STDOM = 'U';
C             For a discrete-time system (DICO = 'D'):
C               Abs(lambda(A)) < ALPHA if STDOM = 'S';
C               Abs(lambda(A)) > ALPHA if STDOM = 'U'.
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 matrix B.
C             On exit, the leading N-by-M part of this array contains
C             the transformed input matrix inv(U) * B.
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 output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed output matrix C * U.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     NDIM    (output) INTEGER
C             The number of eigenvalues of A lying inside the domain of
C             interest for eigenvalues.
C
C     U       (output) DOUBLE PRECISION array, dimension (LDU,N)
C             The leading N-by-N part of this array contains the
C             transformation matrix used to reduce A to the block-
C             diagonal form. The first NDIM columns of U span the
C             invariant subspace of A corresponding to the eigenvalues
C             of its leading diagonal block. The last N-NDIM columns
C             of U span the reducing subspace of A corresponding to
C             the eigenvalues of the trailing diagonal block of A.
C
C     LDU     INTEGER
C             The leading dimension of array U.  LDU >= max(1,N).
C
C     WR, WI  (output) DOUBLE PRECISION arrays, dimension (N)
C             WR and WI contain the real and imaginary parts,
C             respectively, of the computed eigenvalues of A. The
C             eigenvalues will be in the same order that they appear on
C             the diagonal of the output real Schur form of A. Complex
C             conjugate pairs of eigenvalues will appear consecutively
C             with the eigenvalue having the positive imaginary part
C             first.
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)   if JOBA = 'S';
C             LDWORK >= MAX(1,3*N) if JOBA = 'G'.
C             For optimum performance LDWORK should be larger.
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 QR algorithm failed to compute all the
C                  eigenvalues of A;
C             = 2: a failure occured during the ordering of the real
C                  Schur form of A;
C             = 3: the separation of the two diagonal blocks failed
C                  because of very close eigenvalues.
C
C     METHOD
C
C     A similarity transformation U is determined that reduces the
C     system state-matrix A to a block-diagonal form (with two diagonal
C     blocks), so that the leading diagonal block of the resulting A has
C     eigenvalues in a specified domain of the complex plane. The
C     determined transformation is applied to the system (A,B,C) as
C       A <-- inv(U)*A*U, B <-- inv(U)*B and C <-- C*U.
C
C     REFERENCES
C
C     [1] Safonov, M.G., Jonckheere, E.A., Verma, M., Limebeer, D.J.N.
C         Synthesis of positive real multivariable feedback systems.
C         Int. J. Control, pp. 817-842, 1987.
C
C     NUMERICAL ASPECTS
C                                     3
C     The algorithm requires about 14N  floating point operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen, March 1998.
C     Based on the RASP routine SADSDC.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Invariant subspace, real Schur form, similarity transformation,
C     spectral factorization.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER        DICO, JOBA, STDOM
      INTEGER          INFO, LDA, LDB, LDC, LDU, LDWORK, M, N, NDIM, P
      DOUBLE PRECISION ALPHA
C     .. Array Arguments ..
      DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), U(LDU,*),
     $                 WI(*), WR(*)
C     .. Local Scalars ..
      LOGICAL          DISCR, LJOBG
      INTEGER          NDIM1, NR
      DOUBLE PRECISION SCALE
C     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
C     .. External Subroutines ..
      EXTERNAL         DGEMM, DLASET, DTRSYL, TB01LD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC        MAX
C
C     .. Executable Statements ..
C
      INFO = 0
      DISCR = LSAME( DICO, 'D' )
      LJOBG = LSAME( JOBA, 'G' )
C
C     Check input scalar arguments.
C
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( LSAME( STDOM, 'S' ) .OR.
     $                 LSAME( STDOM, 'U' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT. ( LSAME( JOBA, 'S' ) .OR. LJOBG ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( M.LT.0 ) THEN
         INFO = -5
      ELSE IF( P.LT.0 ) THEN
         INFO = -6
      ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN
         INFO = -7
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -13
      ELSE IF( LDU.LT.MAX( 1, N ) ) THEN
         INFO = -16
      ELSE IF( LDWORK.LT.MAX( 1,   N ) .OR.
     $         LDWORK.LT.MAX( 1, 3*N ) .AND. LJOBG ) THEN
         INFO = -20
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TB01KD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      NDIM = 0
      IF( N.EQ.0 )
     $   RETURN
C
C     Reduce A to an ordered real Schur form using an orthogonal
C     similarity transformation A <- U'*A*U and accumulate the
C     transformations in U. The reordering of the real Schur form of A
C     is performed in accordance with the values of the parameters DICO,
C     STDOM and ALPHA. Apply the transformation to B and C: B <- U'*B
C     and C <- C*U. The eigenvalues of A are computed in (WR,WI).
C
C     Workspace:  need   3*N (if JOBA = 'G'), or N (if JOBA = 'S');
C                 prefer larger.
C
      CALL TB01LD( DICO, STDOM, JOBA, N, M, P, ALPHA, A, LDA, B, LDB, C,
     $             LDC, NDIM, U, LDU, WR, WI, DWORK, LDWORK, INFO )
C
      IF ( INFO.NE.0 )
     $    RETURN
C
      IF ( NDIM.GT.0 .AND. NDIM.LT.N ) THEN
C
C        Reduce A to a block-diagonal form by a similarity
C        transformation of the form
C               -1                  ( I -X )
C         A <- T  AT,  where    T = (      )  and X satisfies the
C                                   ( 0  I )
C        Sylvester equation
C
C          A11*X - X*A22 = A12.
C
         NR = N - NDIM
         NDIM1 = NDIM + 1
         CALL DTRSYL( 'N', 'N', -1, NDIM, NR, A, LDA, A(NDIM1,NDIM1),
     $                LDA, A(1,NDIM1), LDA, SCALE, INFO )
         IF ( INFO.NE.0 ) THEN
            INFO = 3
            RETURN
         END IF
C                      -1
C        Compute B <- T  B,  C <- CT,  U <- UT.
C
         SCALE = ONE/SCALE
         CALL DGEMM( 'N', 'N', NDIM, M, NR, SCALE, A(1,NDIM1), LDA,
     $               B(NDIM1,1), LDB, ONE, B, LDB )
         CALL DGEMM( 'N', 'N', P, NR, NDIM, -SCALE, C, LDC, A(1,NDIM1),
     $               LDA, ONE, C(1,NDIM1), LDC )
         CALL DGEMM( 'N', 'N', N, NR, NDIM, -SCALE, U, LDU, A(1,NDIM1),
     $               LDA, ONE, U(1,NDIM1), LDU )
C
C        Set A12 to zero.
C
         CALL DLASET( 'Full', NDIM, NR, ZERO, ZERO, A(1,NDIM1), LDA )
      END IF
C
C     Set to zero the lower triangular part under the first subdiagonal
C     of A.
C
      IF ( N.GT.2 )
     $   CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A( 3, 1 ), LDA )
      RETURN
C *** Last line of TB01KD ***
      END


!-----------------------------------------------------------------------
subroutine sub_HSMAC_adj(ustg,vstg,pcnt)
!-----------------------------------------------------------------------
  use mod_variables,only : imax,jmax,dx,divmax,itrp,divg,iblk,dt
  implicit none
!
!-----------------------------------------------------------------------
  integer :: itrmax = 10     ! total # of iteration
  real(8) :: epsmax = 1.d-12 ! max tolerance
  real(8) :: omg    = 1.5d0  ! accel. coef.
!-----------------------------------------------------------------------
!
  integer :: ic,jc,im,jm,ip,jp
  real(8) :: ibl,dp,dive,dtdx
  real(8) :: ibl_xm,ibl_xp,ibl_ym,ibl_yp
  real(8) :: UD1X_TMP,VD1Y_TMP
  real(8) :: C0,dxi
  real(8) :: ustg(imax+1,jmax  )
  real(8) :: vstg(imax  ,jmax+1)
  real(8) :: pcnt(imax  ,jmax  )
!-----------------------------------------------------------------------
!
  C0  =-omg/(2.d0*dt*(2.d0/(dx**2)))
  dxi = 1.d0/dx
!
  do itrp=1,itrmax
!
!   divmax = 0.d0
!
    do jc=jmax-1,2,-1
    do ic=imax-1,2,-1
!
      im             = ic-1
      jm             = jc-1
      ip             = ic+1
      jp             = jc+1
!
      ibl            = dble(iblk(ic,jc))
      ibl_xm         = dble(iblk(im,jc))
      ibl_xp         = dble(iblk(ip,jc))
      ibl_ym         = dble(iblk(ic,jm))
      ibl_yp         = dble(iblk(ic,jp))
!
!-----velocity correction
      dp          =     -ustg(ic,jc)*ibl_xm
      dp          = (dp)+ustg(ip,jc)*ibl_xp
      dp          = (dp)-vstg(ic,jc)*ibl_ym
      dp          = (dp)+vstg(ic,jp)*ibl_yp
!
!-----pressure correction
      dp          = dp*dt*dxi
!
!-----pressure update
      dp          = (dp)+pcnt(ic,jc)
      dive        = C0*dp
!
!---> Divergence
      UD1X_TMP    = dive*dxi*ibl
      VD1Y_TMP    = dive*dxi*ibl
!
!---- U
      ustg(ic,jc) = (ustg(ic,jc))-UD1X_TMP
      ustg(ip,jc) = (ustg(ip,jc))+UD1X_TMP
!---- V
      vstg(ic,jc) = (vstg(ic,jc))-VD1Y_TMP
      vstg(ic,jp) = (vstg(ic,jp))+VD1Y_TMP
!
!     divmax         = max(divmax,abs(divg(ic,jc)))
!
    enddo
    enddo
!
    call sub_bc_outer_adj(ustg,vstg,pcnt)
    call sub_bc_wall_adj (ustg,vstg,pcnt)
!
!   if(divmax<epsmax) exit
!
  enddo
!
  return
end subroutine sub_HSMAC_adj
!-----------------------------------------------------------------------


! ******************************************************************************************************************************** !
! sedgem_box_ridgwell2001_sedflx.f90
! Opal sediment diagenesis routines
! ******************************************************************************************************************************** !

MODULE sedgem_box_ridgwelletal2003_sedflx

  use genie_control
  USE gem_cmn
  IMPLICIT NONE
  SAVE

  ! *** global configuration parameters ***
  ! set the maximum real number precision to be used
  INTEGER,PARAMETER::nzmax = 52                              ! total number of sediment sub-layers
  INTEGER,PARAMETER::kmax = 51                               ! number of sediment sub-layers used to calculate dissolution flux
  ! constants
  REAL,PARAMETER::T0 = 273.15                                !
  REAL,PARAMETER::DSi0 = 4.59E-06                            ! [Si] diffusivity (cm2 s-1) in free water at 0'C
  REAL,PARAMETER::BSi0 = 4.75E-09                            ! bioturbational diffusivity (cm2 s-1) (== 150 cm2 kyr-1)
  REAL,PARAMETER::df_thesh = 1.0E-5                          ! threshold for virtual steady-state (== 0.001%)
  REAL,PARAMETER::t_step = 2.0E+06                           ! time step (s)
  INTEGER,PARAMETER::t_loop_max = 1000000                    ! maximum allowed time steps

CONTAINS

! *************************************************************************************************
! *** sedflx **************************************************************************************
! *************************************************************************************************
  function fun_ridgwelletal2003_sedflx(dum_frac_opal,dum_SiO2,dum_T,dum_KSi0,dum_opaltorefrac)
    ! result variable
    real::fun_ridgwelletal2003_sedflx
    ! dummy variables
    REAL,INTENT(IN)::dum_frac_opal,dum_SiO2,dum_T,dum_KSi0,dum_opaltorefrac
    ! local variables
    INTEGER::t
    REAL::conc_Si_eq
    REAL::fSi_new,fSi_old
    REAL,DIMENSION(nzmax)::delz
    REAL,DIMENSION(nzmax)::z
    REAL,DIMENSION(nzmax)::sed_pore
    REAL,DIMENSION(nzmax)::sed_conc_Si
    REAL,DIMENSION(nzmax)::DSi
    REAL,DIMENSION(nzmax)::KSi

    ! *** set local variables ***
    ! configuration parameters
    delz(:) = 10.0 / (kmax - 1.0)
    delz(1) = 0.0
    delz(kmax + 1:nzmax) = 1.0
    ! zero variables
    conc_Si_eq = 0.0
    fSi_new = 0.0
    fSi_old = 0.0

    ! ***  ***
    ! calculate sub-layer mid-depth profile
    z(:) = calc_z(z(:))
    ! initialize sediment system
    CALL init_sedflx_Si(dum_SiO2,sed_conc_Si(:))
    ! calculate porosity profile
    sed_pore(:) = calc_pore(z(:))
    ! calculate [Si] diffusivity profile
    DSi(:) = calc_DSi(dum_T,sed_pore(:))
    ! calculate equilibrium [Si]
    conc_Si_eq = calc_conc_Si_eq(dum_T)
    ! convert equilibriun [Si] to sediment asymptotic [Si] according sediment detrital content
    conc_Si_eq = conv_si_eqlibtoasympt(dum_opaltorefrac)*conc_Si_eq
    ! calculate silica dissolution flux
    DO t = 1,t_loop_max
       !
       fSi_old = fSi_new
       ! calculate Si dissolution rate constant profile
       !    KSi(:) = calc_KSi(dum_KSi0,conc_Si_eq,sed_conc_Si(:))
       KSi(:) = calc_KSi_alt(z(:),dum_KSi0,dum_T,conc_Si_eq,sed_conc_Si(:))
       ! calculate Si fluxes
       ! update [Si] profile
       CALL runge_kutta_4_opal(t_step,dum_frac_opal,sed_conc_Si,sed_pore,delz,DSi,KSi)
       ! test Si sediment interface flux
       fSi_new = DSi(2) * conv_cm3_kg * (sed_conc_Si(2) - sed_conc_Si(1)) / (0.5 * delz(2))
       IF (ABS((fSi_new - fSi_old) / fSi_new) <= df_thesh) EXIT
    ENDDO
    !
    fun_ridgwelletal2003_sedflx = fSi_new

  END function fun_ridgwelletal2003_sedflx
! *************************************************************************************************

! ******************************************
! *** calculate sediment sub-layer depth ***
! ******************************************
  FUNCTION calc_z(delz)
    IMPLICIT NONE
! result variable
    REAL,DIMENSION(nzmax)::calc_z
! dummy arguments
    REAL,INTENT(in),DIMENSION(nzmax)::delz
! local variables
    INTEGER::k
! calculate z and return function value
    calc_z(1) = 0.0
    DO k = 2,kmax
      calc_z(k) = 0.5 * delz(k) + SUM(delz(1:k - 1))
    END DO
  END FUNCTION calc_z
! ******************************************

! *******************************************
! *** calculate sediment porosity profile ***
! *******************************************
  FUNCTION calc_pore(z)
    IMPLICIT NONE
! result variable
    REAL,DIMENSION(nzmax)::calc_pore
! dummy arguments
    REAL,INTENT(in),DIMENSION(nzmax)::z
! local variables
    INTEGER::k
! calculate porosity profile and return function value
    calc_pore(1) = 1.0
    DO k = 2,kmax
      calc_pore(k) = 0.690 + 0.260 * (z(k) + 1.0)**(-1.2)
    ENDDO
    calc_pore(kmax + 1:nzmax) = calc_pore(kmax)
  END FUNCTION calc_pore
! *******************************************

! *********************************************************
! *** calculate sediment porosity profile (alternative) ***
! *********************************************************
  FUNCTION calc_pore_alt(sedconcCaCO3,z)
    IMPLICIT NONE
! result variable
    REAL,DIMENSION(nzmax)::calc_pore_alt
! dummy arguments
    REAL,INTENT(in)::sedconcCaCO3
    REAL,INTENT(in),DIMENSION(nzmax)::z
! local variables
    INTEGER::k
! calculate porosity profile and return function value
    calc_pore_alt(1) = 1.0
    DO k = 2,kmax
      calc_pore_alt(k) = 0.690 + 0.260 * EXP(-z(k) / (21.5 - 20.0 * sedconcCaCO3))
    ENDDO
    calc_pore_alt(kmax + 1:nzmax) = calc_pore_alt(kmax)
  END FUNCTION calc_pore_alt
! *********************************************************

! ******************************************
! *** calculate opal solubility constant ***
! ******************************************
  FUNCTION calc_conc_Si_eq(botT)
    IMPLICIT NONE
! result variable
    REAL::calc_conc_Si_eq
! dummy arguments
    REAL,INTENT(in)::botT
! calculate conc_Si_eq and return function value
! NOTE: change units from (umol kg-1) to (mol kg-1)
    calc_conc_Si_eq = 10.0**(6.44 - 968.0 / botT)
    calc_conc_Si_eq = 1.0E-06 * calc_conc_Si_eq
  END FUNCTION calc_conc_Si_eq
! ******************************************

! ************************************************************
! *** convert equilibriun [Si] to sediment asymptotic [Si] ***
! ************************************************************
  FUNCTION conv_si_eqlibtoasympt(opaltorefrac)
    IMPLICIT NONE
! result variable
    REAL::conv_si_eqlibtoasympt
! dummy arguments
    REAL,INTENT(in)::opaltorefrac
! convert equilibriun [Si] to sediment asymptotic [Si] according sediment detrital content
    conv_si_eqlibtoasympt = 1.0 - (0.045 * opaltorefrac)**0.60
  END FUNCTION conv_si_eqlibtoasympt
! ************************************************************

! ******************************************************
! *** calculate Si dissolution rate constant profile ***
! ******************************************************
  FUNCTION calc_KSi(KSi0,concSieq,sedconcSi)
    IMPLICIT NONE
! result variable
    REAL,DIMENSION(nzmax)::calc_KSi
! dummy arguments
    REAL,INTENT(in)::KSi0
    REAL,INTENT(in)::concSieq
    REAL,INTENT(in),DIMENSION(nzmax)::sedconcSi
! local variables
    INTEGER::k
    REAL::r_Si
! calculate KSi and return function value
    calc_KSi(1) = 0.0
    DO k = 2,kmax
      IF (sedconcSi(k) > concSieq) THEN
        calc_KSi(k) = 0.0
      ELSE
        r_Si = (concSieq - sedconcSi(k)) / concSieq
        calc_KSi(k) = KSi0 * r_Si
      ENDIF
    END DO
    calc_KSi(kmax + 1:nzmax) = 0.0
  END FUNCTION calc_KSi
! ******************************************************

! ********************************************************************
! *** calculate Si dissolution rate constant profile (alternative) ***
! ********************************************************************
  FUNCTION calc_KSi_alt(z,KSi0,botT,concSieq,sedconcSi)
    IMPLICIT NONE
! result variable
    REAL,DIMENSION(nzmax)::calc_KSi_alt
! dummy arguments
    REAL,INTENT(in),DIMENSION(nzmax)::z
    REAL,INTENT(in)::KSi0
    REAL,INTENT(in)::botT
    REAL,INTENT(in)::concSieq
    REAL,INTENT(in),DIMENSION(nzmax)::sedconcSi
! local variables
    INTEGER::k
    REAL::T_C
    REAL::r_Si
! calculate local constants
    T_C = botT - const_zeroC
! calculate KSi and return function value
! NOTE: exponential decay of kSi with down-core depth after Van Cappellen and Qiu [1997b]
! NOTE: non-linear dependence of kSi with (concSieq - sedconcSi(k)) / concSieq,
!       (plus additional ad hoc temperature dependence), after Van Cappellen and Qiu [1997b]
    calc_KSi_alt(1) = 0.0
    DO k = 2,kmax
      IF (sedconcSi(k) > concSieq) THEN
        calc_KSi_alt(k) = 0.0
      ELSE
        r_Si = (concSieq - sedconcSi(k)) / concSieq
        calc_KSi_alt(k) = KSi0 * (0.25 + 0.75 * EXP(-z(k) / 6.0)) * &
          & (0.160 * (1.0 + T_C / 15.0) * r_Si + 0.5 * ((1.0 + T_C / 400.0)**4.0 * r_Si)**7.0) / 0.660
      ENDIF
    END DO
    calc_KSi_alt(kmax + 1:nzmax) = 0.0
  END FUNCTION calc_KSi_alt
! ********************************************************************

! ******************************************
! *** calculate [Si] diffusivity profile ***
! ******************************************
  FUNCTION calc_DSi(botT,sedpore)
    IMPLICIT NONE
! result variable
    REAL,DIMENSION(nzmax)::calc_DSi
! dummy arguments
    REAL,INTENT(in)::botT
    REAL,INTENT(in),DIMENSION(nzmax)::sedpore
! local variables
    INTEGER::k
    REAL,DIMENSION(nzmax)::form ! formation factor [Ullman and Aller, 1982]
! calculate [Si] diffusivity profile and return function value
! NOTE: [Si] molecular diffusion coefficient (at 0'C) adjusted for temperature
!       (adapted from Hensen et al. [1998])
! NOTE: set the k=1 sub-layer diffusivity equal to that at k=2
! NOTE: calc_DSi(k) = DSi0 / (sedpore(k) * form(k)) : Ullman and Aller [1982]
!       (equivalent to DSi0 * sedpore(k)**1.5)
! NOTE: calc_DSi(k) = DSi0 * sedpore(k)**1.333 : Millington [1959]
    DO k = 2,kmax
      form(k) = 1.0 / (sedpore(k)**2.5)
      calc_DSi(k) = (DSi0 + 1.74E-07 * (botT - const_zeroC)) / (sedpore(k) * form(k))
    ENDDO
    calc_DSi(1) = DSi0 + 1.74E-07 * (botT - const_zeroC)
    calc_DSi(kmax + 1:nzmax) = calc_DSi(kmax)
  END FUNCTION calc_DSi
! ******************************************

! *****************************************
! *** initialize opal diagenesis scheme ***
! *****************************************
  SUBROUTINE init_sedflx_Si(botconcSi,sedconcSi)
    IMPLICIT NONE
! dummy arguments
    REAL,INTENT(in)::botconcSi
    REAL,INTENT(inout),DIMENSION(nzmax)::sedconcSi
! initialzie [Si] to ambient
    sedconcSi(:) = botconcSi
  END SUBROUTINE init_sedflx_Si
! *****************************************

! ******************************************************************
! *** calculate sediment Si distribution change due to diffusion ***
! ******************************************************************
  FUNCTION calc_dsed_Si_diff(DSi,sedconcSi,delz)
    IMPLICIT NONE
! result variable
    REAL,DIMENSION(nzmax)::calc_dsed_Si_diff
! dummy arguments
    REAL,INTENT(in),DIMENSION(nzmax)::DSi
    REAL,INTENT(in),DIMENSION(nzmax)::sedconcSi
    REAL,INTENT(in),DIMENSION(nzmax)::delz
! local variables
    INTEGER::k
! calculate change in [Si] in each sub-layer pore-space and return function value
! NOTE: use average Si diffusivity
! NOTE: as [Si] is in stored in units of (mol kg-1),
!       the units must be converted into (mol cm-3) in order to calculate the Si flux
    calc_dsed_Si_diff(1) = 0.0
    DO k = 2,kmax
      calc_dsed_Si_diff(k) = &
        & 0.5 * (DSi(k + 1) + DSi(k)) * &
        & (sedconcSi(k + 1) - sedconcSi(k)) / (0.5 * (delz(k + 1) + delz(k))) + &
        & 0.5 * (DSi(k - 1) + DSi(k)) * &
        & (sedconcSi(k - 1) - sedconcSi(k)) / (0.5 * (delz(k - 1) + delz(k)))
    ENDDO
    calc_dsed_Si_diff(kmax + 1:nzmax) = 0.0
    calc_dsed_Si_diff(:) = conv_cm3_kg * calc_dsed_Si_diff(:)
  END FUNCTION calc_dsed_Si_diff
! ******************************************************************

! ********************************************************************
! *** calculate sediment Si distribution change due to dissolution ***
! ********************************************************************
  FUNCTION calc_dsed_Si_diss(sedconcopal,delz,sedpore,KSi)
    IMPLICIT NONE
! result variable
    REAL,DIMENSION(nzmax)::calc_dsed_Si_diss
! dummy arguments
    REAL,INTENT(in)::sedconcopal
    REAL,INTENT(in),DIMENSION(nzmax)::delz
    REAL,INTENT(in),DIMENSION(nzmax)::sedpore
    REAL,INTENT(in),DIMENSION(nzmax)::KSi
! local variables
    INTEGER::k
! return function value
    calc_dsed_Si_diss(1) = 0.0
    DO k = 2,kmax
      calc_dsed_Si_diss(k) = KSi(k) * sedconcopal * delz(k) * (1.0 - sedpore(k)) * conv_opal_cm3_mol
    ENDDO
    calc_dsed_Si_diss(kmax + 1:nzmax) = 0.0
  END FUNCTION calc_dsed_Si_diss
! ********************************************************************

! *********************************************************************
! *** calculate sediment Si distribution change due to bioturbation ***
! *********************************************************************
  FUNCTION calc_dsed_Si_biot(sedconcSi,delz)
    IMPLICIT NONE
! result variable
    REAL,DIMENSION(nzmax)::calc_dsed_Si_biot
! dummy arguments
    REAL,INTENT(in),DIMENSION(nzmax)::sedconcSi
    REAL,INTENT(in),DIMENSION(nzmax)::delz
! local variables
    INTEGER::k
    REAL,DIMENSION(nzmax)::temp_sedconcSi
! make a temporary sediment [Si] profile
! NOTE: set the k = 1 layer [Si] to that of k = 2
    temp_sedconcSi(:) = sedconcSi(:)
    temp_sedconcSi(1) = sedconcSi(2)
! calculate change in [Si] in each sub-layer pore-space and return function value
! NOTE: assume a uniform bioturbation rate with depth in the sediments
! NOTE: as [Si] is in stored in units of (mol kg-1),
!       the units must be converted into (mol cm-3) in order to calculate the Si flux
    calc_dsed_Si_biot(1) = 0.0
    DO k = 2,kmax
      calc_dsed_Si_biot(k) = BSi0 * ( &
        & (sedconcSi(k + 1) - sedconcSi(k)) / (0.5 * (delz(k + 1) + delz(k))) + &
        & (sedconcSi(k - 1) - sedconcSi(k)) / (0.5 * (delz(k - 1) + delz(k))) )
    ENDDO
    calc_dsed_Si_biot(kmax + 1:nzmax) = 0.0
    calc_dsed_Si_biot(:) = conv_cm3_kg * calc_dsed_Si_biot(:)
  END FUNCTION calc_dsed_Si_biot
! *********************************************************************

! ****************************************************
! *** convert 2-digit number into character string ***
! ****************************************************
  FUNCTION conv_num_char(n)
    IMPLICIT NONE
! result variable
    CHARACTER(LEN=2)::conv_num_char
! dummy valiables
    INTEGER,INTENT(in)::n
! return value
    IF (n <= 9) THEN
      WRITE(conv_num_char(2:2),'(i1)')n
      conv_num_char(1:1) = "0"
    ELSE
      WRITE(conv_num_char(1:2),'(i2)')n
    ENDIF
  END FUNCTION conv_num_char
! ****************************************************

! *********************************
! *** [Si] dierivative function ***
! *********************************
  FUNCTION calc_dSidt(sedconcopal,sedconcSi,sedpore,delz,DSi,KSi)
    IMPLICIT NONE
! result variable
    REAL,DIMENSION(nzmax)::calc_dSidt
! dummy variables
    REAL,INTENT(in)::sedconcopal
    REAL,INTENT(in),DIMENSION(nzmax)::sedconcSi
    REAL,INTENT(in),DIMENSION(nzmax)::sedpore
    REAL,INTENT(in),DIMENSION(nzmax)::delz
    REAL,INTENT(in),DIMENSION(nzmax)::DSi
    REAL,INTENT(in),DIMENSION(nzmax)::KSi
! local variables
    INTEGER::k
    REAL,DIMENSION(nzmax)::dsed_Si_diff
    REAL,DIMENSION(nzmax)::dsed_Si_diss
    REAL,DIMENSION(nzmax)::dsed_Si_biot
!
    dsed_Si_diff = calc_dsed_Si_diff(DSi,sedconcSi,delz)
    dsed_Si_diss = calc_dsed_Si_diss(sedconcopal,delz,sedpore,KSi)
    dsed_Si_biot = calc_dsed_Si_biot(sedconcSi,delz)
!
    calc_dSidt(1) = 0.0
    DO k = 2,kmax
      calc_dSidt(k) = (dsed_Si_diff(k) + dsed_Si_diss(k) + dsed_Si_biot(k)) / (sedpore(k) * delz(k))
    END DO
    calc_dSidt(kmax + 1:nzmax) = calc_dSidt(kmax)
  END FUNCTION calc_dSidt
! *********************************

! *******************************************************************
! *** 4th order Runge-Kutta differential equation solving routine ***
! *******************************************************************
  SUBROUTINE runge_kutta_4_opal(dt,sedconcopal,sedconcSi,sedpore,delz,DSi,KSi)
    IMPLICIT NONE
! dummy variables
    REAL,INTENT(in)::dt
    REAL,INTENT(in)::sedconcopal
    REAL,INTENT(inout),DIMENSION(nzmax)::sedconcSi
    REAL,INTENT(in),DIMENSION(nzmax)::sedpore
    REAL,INTENT(in),DIMENSION(nzmax)::delz
    REAL,INTENT(in),DIMENSION(nzmax)::DSi
    REAL,INTENT(in),DIMENSION(nzmax)::KSi
! local variables
    REAL,DIMENSION(nzmax)::conc_Si0
    REAL,DIMENSION(nzmax)::k1,k2,k3,k4
! store initial value of Si
    conc_Si0 = sedconcSi
! calculate coefficient 'k1'
    k1 = dt * calc_dSidt(sedconcopal,conc_Si0,sedpore,delz,DSi,KSi)
! calculate coefficient 'k2'
    k2 = dt * calc_dSidt(sedconcopal,conc_Si0 + 0.5 * k1,sedpore,delz,DSi,KSi)
! calculate coefficient 'k3'
    k3 = dt * calc_dSidt(sedconcopal,conc_Si0 + 0.5 * k2,sedpore,delz,DSi,KSi)
! calculate coefficient 'k4'
    k4 = dt * calc_dSidt(sedconcopal,conc_Si0 + k3,sedpore,delz,DSi,KSi)
! estimate the value at forward time t + dt
    sedconcSi = conc_Si0 + (k1 + 2.0 * k2 + 2.0 * k3 + k4) / 6.0
  END SUBROUTINE runge_kutta_4_opal
! *******************************************************************

END MODULE sedgem_box_ridgwelletal2003_sedflx


!    Copyright (C) 2012 The SPEED FOUNDATION
!    Author: Ilario Mazzieri
!
!    This file is part of SPEED.
!
!    SPEED is free software; you can redistribute it and/or modify it
!    under the terms of the GNU Affero General Public License as
!    published by the Free Software Foundation, either version 3 of the
!    License, or (at your option) any later version.
!
!    SPEED 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
!    Affero General Public License for more details.
!
!    You should have received a copy of the GNU Affero General Public License
!    along with SPEED.  If not, see <http://www.gnu.org/licenses/>.

!> @brief Makes normal vector of a given surface.
!! @author Ilario Mazzieri
!> @date September, 2013
!> @version 1.0
!> @param[in] ind  face of the hex
!> @param[in] xs1 x-coordinate of the 1-node defining the face
!> @param[in] xs2 x-coordinate of the 2-node defining the face
!> @param[in] xs3 x-coordinate of the 3-node defining the face
!> @param[in] xs4 x-coordinate of the 4-node defining the face
!> @param[in] ys1 y-coordinate of the 1-node defining the face
!> @param[in] ys2 y-coordinate of the 2-node defining the face
!> @param[in] ys3 y-coordinate of the 3-node defining the face
!> @param[in] ys4 y-coordinate of the 4-node defining the face
!> @param[in] zs1 z-coordinate of the 1-node defining the face
!> @param[in] zs2 z-coordinate of the 2-node defining the face
!> @param[in] zs3 z-coordinate of the 3-node defining the face
!> @param[in] zs4 z-coordinate of the 4-node defining the face
!> @param[in] par  control parameter (dummy)
!> @param[in] arr  control parameter (dummy)
!> @param[out] nx x-component of the normal vector
!> @param[out] ny y-component of the normal vector
!> @param[out] nz z-component of the normal vector

    subroutine MAKE_NORMAL(ind, xs1, xs2, xs3, xs4, &
                       ys1, ys2, ys3, ys4, &
                       zs1, zs2, zs3, zs4, &
                       nx,ny,nz, par, arr)

        implicit none

        integer*4, intent(in) :: ind, par, arr

        real*8 :: a1,a2,a3,b1,b2,b3,aplane,bplane,cplane
        real*8 :: norm1, norm2, norm3, norm4
        real*8 :: nx1, nx2, nx3, nx4
        real*8 :: ny1, ny2, ny3, ny4
        real*8 :: nz1, nz2, nz3, nz4

        real*8, intent(in)  :: xs1, xs2, xs3, xs4, ys1, ys2, ys3, ys4, zs1, zs2, zs3, zs4
        real*8, intent(out) :: nx,ny,nz

         select case (ind)

         case(1,3,5)
            a1 = xs4-xs1
            a2 = ys4-ys1
            a3 = zs4-zs1
            b1 = xs2-xs1
            b2 = ys2-ys1
            b3 = zs2-zs1
            aplane =  a2*b3 - a3*b2
            bplane = -a1*b3 + a3*b1
            cplane =  a1*b2 - a2*b1

            norm1 =  aplane**2.d0 + bplane**2.d0 + cplane**2.d0
                nx1 = aplane/dsqrt(norm1)
            ny1 = bplane/dsqrt(norm1)
            nz1 = cplane/dsqrt(norm1)

            a1 = xs1-xs2
            a2 = ys1-ys2
            a3 = zs1-zs2
            b1 = xs3-xs2
            b2 = ys3-ys2
            b3 = zs3-zs2
            aplane =  a2*b3 - a3*b2
            bplane = -a1*b3 + a3*b1
            cplane =  a1*b2 - a2*b1

            norm2 =  aplane**2.d0 + bplane**2.d0 + cplane**2.d0
                nx2 = aplane/dsqrt(norm2)
            ny2 = bplane/dsqrt(norm2)
            nz2 = cplane/dsqrt(norm2)

            a1 = xs2-xs3
            a2 = ys2-ys3
            a3 = zs2-zs3
            b1 = xs4-xs3
            b2 = ys4-ys3
            b3 = zs4-zs3
            aplane =  a2*b3 - a3*b2
            bplane = -a1*b3 + a3*b1
            cplane =  a1*b2 - a2*b1

            norm3 =  aplane**2.d0 + bplane**2.d0 + cplane**2.d0
                nx3 = aplane/dsqrt(norm3)
            ny3 = bplane/dsqrt(norm3)
            nz3 = cplane/dsqrt(norm3)

            a1 = xs3-xs4
            a2 = ys3-ys4
            a3 = zs3-zs4
            b1 = xs1-xs4
            b2 = ys1-ys4
            b3 = zs1-zs4
            aplane =  a2*b3 - a3*b2
            bplane = -a1*b3 + a3*b1
            cplane =  a1*b2 - a2*b1

            norm4 =  aplane**2.d0 + bplane**2.d0 + cplane**2.d0
                nx4 = aplane/dsqrt(norm4)
            ny4 = bplane/dsqrt(norm4)
            nz4 = cplane/dsqrt(norm4)

            nx = (nx1 + nx2 + nx3 + nx4)/4.d0
            ny = (ny1 + ny2 + ny3 + ny4)/4.d0
            nz = (nz1 + nz2 + nz3 + nz4)/4.d0

         case(2,4,6)

           a1 = xs2-xs1
           a2 = ys2-ys1
           a3 = zs2-zs1
                 b1 = xs4-xs1
           b2 = ys4-ys1
           b3 = zs4-zs1
           aplane =  a2*b3 - a3*b2
           bplane = -a1*b3 + a3*b1
           cplane =  a1*b2 - a2*b1

           norm1 =  aplane**2.d0 + bplane**2.d0 + cplane**2.d0
           nx1 = aplane/dsqrt(norm1)
           ny1 = bplane/dsqrt(norm1)
           nz1 = cplane/dsqrt(norm1)

           a1 = xs3-xs2
           a2 = ys3-ys2
           a3 = zs3-zs2
                 b1 = xs1-xs2
           b2 = ys1-ys2
           b3 = zs1-zs2
           aplane =  a2*b3 - a3*b2
           bplane = -a1*b3 + a3*b1
           cplane =  a1*b2 - a2*b1

           norm2 =  aplane**2.d0 + bplane**2.d0 + cplane**2.d0
           nx2 = aplane/dsqrt(norm2)
           ny2 = bplane/dsqrt(norm2)
           nz2 = cplane/dsqrt(norm2)

           a1 = xs4-xs3
           a2 = ys4-ys3
           a3 = zs4-zs3
                 b1 = xs2-xs3
           b2 = ys2-ys3
           b3 = zs2-zs3
           aplane =  a2*b3 - a3*b2
           bplane = -a1*b3 + a3*b1
           cplane =  a1*b2 - a2*b1

           norm3 =  aplane**2.d0 + bplane**2.d0 + cplane**2.d0
           nx3 = aplane/dsqrt(norm3)
           ny3 = bplane/dsqrt(norm3)
           nz3 = cplane/dsqrt(norm3)

           a1 = xs1-xs4
           a2 = ys1-ys4
           a3 = zs1-zs4
                 b1 = xs3-xs4
           b2 = ys3-ys4
           b3 = zs3-zs4
           aplane =  a2*b3 - a3*b2
           bplane = -a1*b3 + a3*b1
           cplane =  a1*b2 - a2*b1

           norm4 =  aplane**2.d0 + bplane**2.d0 + cplane**2.d0
           nx4 = aplane/dsqrt(norm4)
           ny4 = bplane/dsqrt(norm4)
           nz4 = cplane/dsqrt(norm4)

            nx = (nx1 + nx2 + nx3 + nx4)/4.d0
            ny = (ny1 + ny2 + ny3 + ny4)/4.d0
            nz = (nz1 + nz2 + nz3 + nz4)/4.d0

         end select

end subroutine MAKE_NORMAL


      function xnorm(sigma)
c   xnorm  - function which generates successive random samples from a
c             normal population at each call
c        xnorm  uses random number generator ranf and a transformation
c             algorithm to generate the random samples
c) the seed for xnorm can be changed by calling ranset(x)
c)   with x as the new desired seed (can use either a
c)   call statement or dummy function statement
c        the maximum value of xnorm  is limited in the program to
c             approximately three times sigma
c        usage
c           x = xnorm(sigma)
c             x is the variable into which the next sample is stored
c             sigma is standard deviation of desired sequence
	integer seed
	integer LARGE
      data c0,c1,c2,d1,d2,d3/2.515517,.802853,.010328,1.432788,.189269,.
     $001308/
c  Original code uses random number from 0 to 1
c100  u = ranf()-0.5
c     if (abs(u).lt.1.0e-03) go to 100
c
c replacement for Sun
c
  100 u = ((random(seed))/LARGE) - 0.5
      if (abs(u).lt.1.0e-03) go to 100
      sgn = u/abs(u)
      u = 1./(u*u)
      t = alog(u)
      t = sqrt(t)
      a = ((c2*t)+c1)*t+c0
      b = (((d3*t)+d2)*t+d1)*t+1.
      xnorm = (t-(a/b))*sgn*sigma
      return
      end

c $Id$