*DECK CBLKTR
      SUBROUTINE CBLKTR (IFLG, NP, N, AN, BN, CN, MP, M, AM, BM, CM,
     +   IDIMY, Y, IERROR, W)
C***BEGIN PROLOGUE  CBLKTR
C***PURPOSE  Solve a block tridiagonal system of linear equations
C            (usually resulting from the discretization of separable
C            two-dimensional elliptic equations).
C***LIBRARY   SLATEC (FISHPACK)
C***CATEGORY  I2B4B
C***TYPE      COMPLEX (BLKTRI-S, CBLKTR-C)
C***KEYWORDS  ELLIPTIC PDE, FISHPACK, TRIDIAGONAL LINEAR SYSTEM
C***AUTHOR  Adams, J., (NCAR)
C           Swarztrauber, P. N., (NCAR)
C           Sweet, R., (NCAR)
C***DESCRIPTION
C
C     Subroutine CBLKTR is a complex version of subroutine BLKTRI.
C     Both subroutines solve a system of linear equations of the form
C
C          AN(J)*X(I,J-1) + AM(I)*X(I-1,J) + (BN(J)+BM(I))*X(I,J)
C
C          + CN(J)*X(I,J+1) + CM(I)*X(I+1,J) = Y(I,J)
C
C               For I = 1,2,...,M  and  J = 1,2,...,N.
C
C     I+1 and I-1 are evaluated modulo M and J+1 and J-1 modulo N, i.e.,
C
C          X(I,0) = X(I,N),  X(I,N+1) = X(I,1),
C          X(0,J) = X(M,J),  X(M+1,J) = X(1,J).
C
C     These equations usually result from the discretization of
C     separable elliptic equations.  Boundary conditions may be
C     Dirichlet, Neumann, or periodic.
C
C
C     * * * * * * * * * *     On INPUT     * * * * * * * * * *
C
C     IFLG
C       = 0  Initialization only.  Certain quantities that depend on NP,
C            N, AN, BN, and CN are computed and stored in the work
C            array  W.
C       = 1  The quantities that were computed in the initialization are
C            used to obtain the solution X(I,J).
C
C       NOTE   A call with IFLG=0 takes approximately one half the time
C              time as a call with IFLG = 1.  However, the
C              initialization does not have to be repeated unless NP, N,
C              AN, BN, or CN change.
C
C     NP
C       = 0  If AN(1) and CN(N) are not zero, which corresponds to
C            periodic boundary conditions.
C       = 1  If AN(1) and CN(N) are zero.
C
C     N
C       The number of unknowns in the J-direction. N must be greater
C       than 4. The operation count is proportional to MNlog2(N), hence
C       N should be selected less than or equal to M.
C
C     AN,BN,CN
C       Real one-dimensional arrays of length N that specify the
C       coefficients in the linear equations given above.
C
C     MP
C       = 0  If AM(1) and CM(M) are not zero, which corresponds to
C            periodic boundary conditions.
C       = 1  If AM(1) = CM(M) = 0  .
C
C     M
C       The number of unknowns in the I-direction. M must be greater
C       than 4.
C
C     AM,BM,CM
C       Complex one-dimensional arrays of length M that specify the
C       coefficients in the linear equations given above.
C
C     IDIMY
C       The row (or first) dimension of the two-dimensional array Y as
C       it appears in the program calling BLKTRI.  This parameter is
C       used to specify the variable dimension of Y.  IDIMY must be at
C       least M.
C
C     Y
C       A complex two-dimensional array that specifies the values of
C       the right side of the linear system of equations given above.
C       Y must be dimensioned Y(IDIMY,N) with IDIMY .GE. M.
C
C     W
C       A one-dimensional array that must be provided by the user for
C       work space.
C             If NP=1 define K=INT(log2(N))+1 and set L=2**(K+1) then
C                     W must have dimension (K-2)*L+K+5+MAX(2N,12M)
C
C             If NP=0 define K=INT(log2(N-1))+1 and set L=2**(K+1) then
C                     W must have dimension (K-2)*L+K+5+2N+MAX(2N,12M)
C
C       **IMPORTANT** For purposes of checking, the required dimension
C                     of W is computed by BLKTRI and stored in W(1)
C                     in floating point format.
C
C     * * * * * * * * * *     On Output     * * * * * * * * * *
C
C     Y
C       Contains the solution X.
C
C     IERROR
C       An error flag that indicates invalid input parameters.  Except
C       for number zero, a solution is not attempted.
C
C       = 0  No error.
C       = 1  M is less than 5.
C       = 2  N is less than 5.
C       = 3  IDIMY is less than M.
C       = 4  BLKTRI failed while computing results that depend on the
C            coefficient arrays AN, BN, CN.  Check these arrays.
C       = 5  AN(J)*CN(J-1) is less than 0 for some J. Possible reasons
C            for this condition are
C            1. The arrays AN and CN are not correct.
C            2. Too large a grid spacing was used in the discretization
C               of the elliptic equation.
C            3. The linear equations resulted from a partial
C               differential equation which was not elliptic.
C
C     W
C       Contains intermediate values that must not be destroyed if
C       CBLKTR will be called again with IFLG=1.  W(1) contains the
C       number of locations required by W in floating point format.
C
C *Long Description:
C
C     * * * * * * *   Program Specifications    * * * * * * * * * * * *
C
C     Dimension of   AN(N),BN(N),CN(N),AM(M),BM(M),CM(M),Y(IDIMY,N)
C     Arguments      W(see argument list)
C
C     Latest         June 1979
C     Revision
C
C     Required       CBLKTR,CBLKT1,PROC,PROCP,CPROC,CPROCP,CCMPB,INXCA,
C     Subprograms    INXCB,INXCC,CPADD,PGSF,PPGSF,PPPSF,BCRH,TEVLC,
C                    R1MACH
C
C     Special        The algorithm may fail if ABS(BM(I)+BN(J)) is less
C     Conditions     than ABS(AM(I))+ABS(AN(J))+ABS(CM(I))+ABS(CN(J))
C                    for some I and J. The algorithm will also fail if
C                    AN(J)*CN(J-1) is less than zero for some J.
C                    See the description of the output parameter IERROR.
C
C     Common         CCBLK
C     Blocks
C
C     I/O            NONE
C
C     Precision      Single
C
C     Specialist     Paul Swarztrauber
C
C     Language       FORTRAN
C
C     History        CBLKTR is a complex version of BLKTRI (version 3)
C
C     Algorithm      Generalized Cyclic Reduction (see reference below)
C
C     Space
C     Required       CONTROL DATA 7600
C
C     Portability    American National Standards Institute FORTRAN.
C                    The machine accuracy is set using function R1MACH.
C
C     Required       NONE
C     Resident
C     Routines
C
C     References     Swarztrauber,P. and R. SWEET, 'Efficient Fortran
C                    Subprograms for the solution of elliptic equations'
C                    NCAR TN/IA-109, July, 1975, 138 PP.
C
C                    SWARZTRAUBER P. ,'A Direct Method for The Discrete
C                    Solution of Separable Elliptic Equations', SIAM
C                    J. Numer. Anal.,11(1974) PP. 1136-1150.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C***REFERENCES  P. N. Swarztrauber and R. Sweet, Efficient Fortran
C                 subprograms for the solution of elliptic equations,
C                 NCAR TN/IA-109, July 1975, 138 pp.
C               P. N. Swarztrauber, A direct method for the discrete
C                 solution of separable elliptic equations, SIAM Journal
C                 on Numerical Analysis 11, (1974), pp. 1136-1150.
C***ROUTINES CALLED  CBLKT1, CCMPB, CPROC, CPROCP, PROC, PROCP
C***COMMON BLOCKS    CCBLK
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CBLKTR
C
      DIMENSION       AN(*)      ,BN(*)      ,CN(*)      ,AM(*)      ,
     1                BM(*)      ,CM(*)      ,Y(IDIMY,*) ,W(*)
      EXTERNAL        PROC       ,PROCP      ,CPROC      ,CPROCP
      COMMON /CCBLK/  NPP        ,K          ,EPS        ,CNV        ,
     1                NM         ,NCMPLX     ,IK
      COMPLEX         AM         ,BM         ,CM         ,Y
C***FIRST EXECUTABLE STATEMENT  CBLKTR
      NM = N
      M2 = M+M
      IERROR = 0
      IF (M-5) 101,102,102
  101 IERROR = 1
      GO TO 119
  102 IF (NM-3) 103,104,104
  103 IERROR = 2
      GO TO 119
  104 IF (IDIMY-M) 105,106,106
  105 IERROR = 3
      GO TO 119
  106 NH = N
      NPP = NP
      IF (NPP) 107,108,107
  107 NH = NH+1
  108 IK = 2
      K = 1
  109 IK = IK+IK
      K = K+1
      IF (NH-IK) 110,110,109
  110 NL = IK
      IK = IK+IK
      NL = NL-1
      IWAH = (K-2)*IK+K+6
      IF (NPP) 111,112,111
C
C     DIVIDE W INTO WORKING SUB ARRAYS
C
  111 IW1 = IWAH
      IWBH = IW1+NM
      W(1) = IW1-1+MAX(2*NM,12*M)
      GO TO 113
  112 IWBH = IWAH+NM+NM
      IW1 = IWBH
      W(1) = IW1-1+MAX(2*NM,12*M)
      NM = NM-1
C
C SUBROUTINE CCMPB COMPUTES THE ROOTS OF THE B POLYNOMIALS
C
  113 IF (IERROR) 119,114,119
  114 IW2 = IW1+M2
      IW3 = IW2+M2
      IWD = IW3+M2
      IWW = IWD+M2
      IWU = IWW+M2
      IF (IFLG) 116,115,116
  115 CALL CCMPB (NL,IERROR,AN,BN,CN,W(2),W(IWAH),W(IWBH))
      GO TO 119
  116 IF (MP) 117,118,117
C
C SUBROUTINE CBLKT1 SOLVES THE LINEAR SYSTEM
C
  117 CALL CBLKT1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2),
     1             W(IW3),W(IWD),W(IWW),W(IWU),PROC,CPROC)
      GO TO 119
  118 CALL CBLKT1 (NL,AN,BN,CN,M,AM,BM,CM,IDIMY,Y,W(2),W(IW1),W(IW2),
     1             W(IW3),W(IWD),W(IWW),W(IWU),PROCP,CPROCP)
  119 CONTINUE
      RETURN
      END


module slf_integrate

  use iso_fortran_env, only: r32 => real32, r64 => real64
  implicit none

  interface integrate
    module procedure integrate32
    module procedure integrate64
  end interface integrate

contains

  pure real(r32) function integrate32(y,x) result(intg)
    real(r32), dimension(:), intent(in) :: x, y
    integer :: n

    if (size(x) /= size(y)) error stop "size(x) /= size(y)"
    if (size(x) < 2) error stop 'size(x) < 2'

    n = size(x)
    intg = sum((y(2:n) + y(1:n-1)) * (x(2:n) - x(1:n-1))) / 2
  end function

  pure real(r64) function integrate64(y,x) result(intg)
    real(r64), dimension(:), intent(in) :: x, y
    integer :: n

    if (size(x) /= size(y)) error stop "size(x) /= size(y)"
    if (size(x) < 2) error stop 'size(x) < 2'

    n = size(x)
    intg = sum((y(2:n) + y(1:n-1)) * (x(2:n) - x(1:n-1))) / 2
  end function

end module slf_integrate

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

module slf_deriv

  use iso_fortran_env, only: r64 => real64
  implicit none

contains

  pure subroutine deriv(x,yin,yout)
    real(r64), intent(in) :: x(:), yin(:)
    real(r64), intent(out) :: yout(:)
    real(r64) :: dx2
    integer :: i,n

    n = size(yout)

    if ( n .lt. 3 ) then
      error stop 'n should be at least 3!'
    end if

    do i=2,n-1
      yout(i) = (yin(i+1)-yin(i-1))/(x(i+1)-x(i-1))
    end do
    dx2 = 2 * ( yin(3) + yin(1) - 2 * yin(2) ) / ( (x(3)-x(2))**2 + (x(2)-x(1))**2 )
    yout(1) = yout(2) + (x(1)-x(2))*dx2
    dx2 = 2 * ( yin(n) + yin(n-2) - 2 * yin(n-1) ) / ( (x(n)-x(n-1))**2 + (x(n-1)-x(n-2))**2 )
    yout(n) = yout(n-1) + (x(n)-x(n-1))*dx2
  end subroutine

  pure subroutine deriv2(x,yin,yout)
    real(r64), intent(in) :: x(:), yin(:)
    real(r64), intent(out) :: yout(:)
    integer :: i,n
    n = size(yout)

    do i=2,n-1
      yout(i) = 2 * ( yin(i+1) + yin(i-1) - 2 * yin(i) ) / ( (x(i+1)-x(i))**2 + (x(i-1)-x(i))**2 )
    end do
    yout(1) = yout(2) + ( x(1) - x(2) )*( yout(3)-yout(2) )/( x(3)-x(2) )
    yout(n) = yout(n-1) + ( x(n) - x(n-1) )*( yout(n-1)-yout(n-2) )/( x(n-1)-x(n-2) )
  end subroutine

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

  pure subroutine diffx(x, y)
    real(r64), intent(in) :: x(:)
    real(r64), intent(out) :: y(:)
    integer :: i, n

    if (size(x) /= size(y)) error stop 'diffx: size(x) /= size(y)'

    n = size(x)
    do concurrent (i = 2:n-1)
      y(i) = (x(i+1) - x(i-1)) / 2
    end do

    y(1) = x(2) - x(1)
    y(n) = x(n) - x(n-1)
  end subroutine

  pure function fdiffx(x) result(y)
    real(r64), intent(in) :: x(:)
    real(r64) :: y(size(x))

    call diffx(x, y)
  end function

   !----------------------------------------------------------------------------!
  ! computes log gradient of any function

  pure subroutine loggrad(x, y, d)
    real(r64), intent(in) :: x(:), y(:)
    real(r64), intent(out) :: d(:)
    integer :: i

    if (size(x) /= size(y) .or. size(d) /= size(y)) error stop 'loggrad: sizes dont match'

    do concurrent (i = 2:size(y)-1)
      d(i) = (y(i+1) - y(i-1)) * (x(i+1) + x(i-1)) &
      &   / ((y(i+1) + y(i-1)) * (x(i+1) - x(i-1)) )
    end do

    d(1) = d(2)
    d(size(d)) = d(size(d) - 1)
  end subroutine

end module


! =================================================
!   Analytical solution.
! =================================================

module analytic_solver

    implicit none
    public :: calc_analytic
    public :: comp_analytic

contains

    subroutine calc_analytic(T, T_)

        use physical_def, only: Lx, Ly, Tn, Ts, Lx_, Ly_, qw_, qe_
        use coordinates,  only: Nx, Ny, x_, y_
        use conv_config,  only: conv_cr, conv_max

        real*8, intent(out) :: T(Nx,Ny), T_(Nx,Ny)

        character(len=:), allocatable :: dir
        real*8,           parameter   :: PI = 4*atan(1.0_8)
        integer*4                     :: n, INF = conv_max
        real*8                        :: T0_(Nx,Ny), err

        ! Series summation
        T0_ = y_/Ly_
        do n = 1, INF
            T_ = T0_ - 2*(-1 + (-1)**n)*Ly_/(n*PI)**2                    &
            &   *(qe_*cosh(n*PI/Ly_*x_) + qw_*cosh(n*PI/Ly_*(Lx_ - x_))) &
            &   /sinh(n*PI*Lx_/Ly_)*sin(n*PI/Ly_*y_)
            call max_deviation(T_, T0_, err)
            if (err > 0 .and. err < conv_cr) exit
            T0_ = T_
        end do
        T = T_*(Tn - Ts) + Ts

        ! Visualization
        dir = ".\\out\\analytic\\"
        call check_dir(dir)
        call save_tecplot_file(dir, 0, "Temperature", T)

    end subroutine calc_analytic

    subroutine comp_analytic(mat_n, mat_a, avg, std)

        use coordinates, only: Nx, Ny

        real*8, intent(in)  :: mat_n(Nx,Ny)
        real*8, intent(in)  :: mat_a(Nx,Ny)
        real*8, intent(out) :: avg, std

        real*8, allocatable :: vec_n(:)
        real*8, allocatable :: vec_a(:)
        real*8, allocatable :: err(:)

        vec_n = reshape(mat_n, (/Nx*Ny/))
        vec_a = reshape(mat_a, (/Nx*Ny/))
        err = (vec_n - vec_a)/vec_a
        avg = sum(err)/(Nx*Ny)
        std = sqrt(sum((err - avg)**2))/(Nx*Ny)

    end subroutine comp_analytic

end module


C$Procedure QDERIV ( Quadratic derivative )

      SUBROUTINE QDERIV ( N, F0, F2, DELTA, DFDT )
      IMPLICIT NONE

C$ Abstract
C
C     Estimate the derivative of a function by finding the derivative
C     of a quadratic approximating function.  This derivative estimate
C     is equivalent to that found by computing the average of forward
C     and backward differences.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     MATH
C     UTILITY
C
C$ Declarations

      INTEGER               N
      DOUBLE PRECISION      F0    ( N )
      DOUBLE PRECISION      F2    ( N )
      DOUBLE PRECISION      DELTA
      DOUBLE PRECISION      DFDT  ( N )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  -------------------------------------------------
C     N          I   Dimension of function to be differentiated.
C     F0         I   Function values at left endpoint.
C     F2         I   Function values at right endpoint.
C     DELTA      I   Separation of abscissa points.
C     DFDT       O   Derivative vector.
C
C$ Detailed_Input
C
C     N              is the dimension of the function to be
C                    differentiated.  The derivative of each
C                    function component will be found.
C
C     F0             is an array of N function values at a point on
C                    the real line; we'll refer to this point as X0.
C
C     F2             is an array of N function values at a second point
C                    on the real line; we'll refer to this point as X2.
C                    The points X0 and X2 must satisfy
C
C                       X2 = X0 + 2 * DELTA
C
C
C     DELTA          is one half of the difference between X2 and X0:
C
C                       DELTA = ( X2 - X0 ) / 2
C
C                    DELTA may be negative but must be non-zero.
C
C$ Detailed_Output
C
C     DFDT           is an N-dimensional vector representing an estimate
C                    of the derivative of the input function at the
C                    midpoint X1 of the interval between X0 and X2.
C
C                    The Ith component of DFDT is
C
C                       ( 1 / (2*DELTA) ) * ( F2(I) - F0(I) )
C
C                    We may regard this estimate as the derivative
C                    at X1 of a parabola fitted to the points
C
C                        ( X0, F0(I) ),  ( X2, F2(I) )
C
C                    We may also regard this derivative as the average
C                    of the forward and backward first-order
C                    differences of the input function defined by
C                    F0(I), F2(I), and DELTA.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If DELTA is zero, the error SPICE(DIVIDEBYZERO) is signaled.
C
C     2) If N is less than 1, this routine will fail in a system-
C        dependent manner.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine estimates the derivative of a vector-valued function
C     using the average of forward and backward differences.
C
C     The derivative estimate computed by this routine is equivalent to
C     that obtained by fitting each component of the function with a
C     parabola at the points
C
C        (X0, F(X0)), (X1, F(X1)), (X2, F(X2))
C
C     where
C
C         X0  =  X1 - DELTA
C         X2  =  X1 + DELTA
C
C     and finding the derivative of the parabolas at X1.
C
C$ Examples
C
C     1) Estimate the derivative of x**2 at x = 2.
C
C           IMPLICIT NONE
C
C           DOUBLE PRECISION     DELTA
C           DOUBLE PRECISION     DFDT  (1)
C           DOUBLE PRECISION     F0    (1)
C           DOUBLE PRECISION     F2    (1)
C           INTEGER              N
C
C           N     = 1
C           DELTA = 1.D-3
C           F0(1) = ( 2.D0 - DELTA ) ** 2.D0
C           F2(1) = ( 2.D0 + DELTA ) ** 2.D0
C
C           CALL QDERIV ( N, F0, F2, DELTA, DFDT )
C
C           WRITE ( *, '(1X,A,E25.16)'  ) '4 - DFDT(1) = ', 4 - DFDT(1)
C           END
C
C        The difference displayed is platform-dependent, but
C        should be on the order of 1.E-12.
C
C$ Restrictions
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C
C$ Literature_References
C
C     None.
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 18-DEC-2004 (NJB)
C
C-&

C$ Index_Entries
C
C        Estimate function derivative using quadratic fit
C
C-&

C
C     Use discovery check-in.
C
      IF ( DELTA .EQ. 0.D0 ) THEN

         CALL CHKIN  ( 'QDERIV'                                    )
         CALL SETMSG ( 'Delta abscissa value is zero; a non-zero ' //
     .                 'value is required.'                        )
         CALL SIGERR ( 'SPICE(DIVIDEBYZERO)'                       )
         CALL CHKOUT ( 'QDERIV'                                    )
         RETURN

      END IF
C
C
C     Our derivative estimate is
C
C            1/2 * (   Backward_difference / DELTA
C                    + Forward_difference  / DELTA )
C
C        =   ( 1/(2*DELTA) ) * ( ( F(X2) - F(X1) ) +  ( F(X1) - F(X0) )
C
C        =   ( 1/(2*DELTA) ) * ( ( F(X2) - F(X0) )
C
C        =    (0.5/DELTA) * F(X2)  +  (-0.5/DELTA) * F(X0)
C
C
      CALL VLCOMG (  N, 0.5D0/DELTA, F2, -0.5D0/DELTA, F0, DFDT )

      RETURN
      END


module fcn_polynomial
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO, ONE, TWO, THREE, FOUR, FIVE, SIX
    use type_function,  only: function_t
    use type_point,     only: point_t
    implicit none
    private

    !>  A polynomial function: up to sixth-order
    !!
    !!  \f$   f(x) = ax^6 + bx^5 + cx^4 + dx^3 + ex^2 + fx + g  \f$
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/14/2016
    !!
    !-------------------------------------------------------------------------
    type, extends(function_t), public :: polynomial_f

    contains

        procedure   :: init
        procedure   :: compute

    end type polynomial_f
    !**************************************************************************

contains

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

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

        !
        ! Set function options to default settings
        !
        ! Options here are polynomial coefficients:
        !   f(x) = ax^6 + bx^5 + cx^4 + dx^3 + ex^2 + fx + g
        !
        call self%add_option('a', ZERO)
        call self%add_option('b', ZERO)
        call self%add_option('c', ZERO)
        call self%add_option('d', ZERO)
        call self%add_option('e', ZERO)
        call self%add_option('f', ZERO)
        call self%add_option('g', ZERO)

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

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

        real(rk)    :: a, b, c, d, e, f, g
        real(rk)    :: x
        real(rk)    :: val

        ! Get x
        x = coord%c1_

        ! Get function options
        a = self%get_option_value('a')
        b = self%get_option_value('b')
        c = self%get_option_value('c')
        d = self%get_option_value('d')
        e = self%get_option_value('e')
        f = self%get_option_value('f')
        g = self%get_option_value('g')

        !   f(x) = ax^6 + bx^5 + cx^4 + dx^3 + ex^2 + fx + g
        val = a*x**SIX + b*x**FIVE + c*x**FOUR + d*x**THREE + e*x**TWO + f*x + g

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

end module fcn_polynomial


SUBROUTINE SETSHLD(TSC,THETA,D,SSG,DSR,USC)

  ! CHANGE RECORD

  ! **  NONCOHESIVE SEDIMENT SETTLING AND SHIELDS CRITERIA
  ! **  USING VAN RIJN'S EQUATIONS

  IMPLICIT NONE

  REAL :: TSC,THETA,D,SSG,DSR,USC,VISC,GP,TMP,GPD

  IF( D <= 1E-8 )THEN
    TSC = 0.0000055
    USC = 0.0023
    RETURN
  ENDIF

  VISC = 1.D-6
  GP = (SSG-1.)*9.82
  TMP = GP/(VISC*VISC)
  DSR = D*(TMP**0.333333)
  GPD = GP*D

  ! **  SHIELDS
  IF(DSR <= 4.0 )THEN
    THETA = 0.24/DSR
  ENDIF
  IF(DSR > 4.0 .AND. DSR <= 10.0 )THEN
    THETA = 0.14/(DSR**0.64)
  ENDIF
  IF(DSR > 10.0 .AND. DSR <= 20.0 )THEN
    THETA = 0.04/(DSR**0.1)
  ENDIF
  IF(DSR > 20.0 .AND. DSR <= 150.0 )THEN
    THETA = 0.013*(DSR**0.29)
  ENDIF
  IF(DSR > 150.0 )THEN
    THETA = 0.055
  ENDIF
  TSC=GPD*THETA
  USC=SQRT(TSC)

END SUBROUTINE


FUNCTION bessi0_s(x)
  use mo_kind
  use mo_nrutil, ONLY : poly
  IMPLICIT NONE
  REAL(SP), INTENT(IN) :: x
  REAL(SP) :: bessi0_s
  REAL(SP) :: ax
  REAL(sp), DIMENSION(7) :: p = (/1.0_sp,3.5156229_sp,&
       3.0899424_sp,1.2067492_sp,0.2659732_sp,0.360768e-1_sp,&
       0.45813e-2_sp/)
  REAL(sp), DIMENSION(9) :: q = (/0.39894228_sp,0.1328592e-1_sp,&
       0.225319e-2_sp,-0.157565e-2_sp,0.916281e-2_sp,&
       -0.2057706e-1_sp,0.2635537e-1_sp,-0.1647633e-1_sp,&
       0.392377e-2_sp/)
  ax=abs(x)
  if (ax < 3.75_sp) then
     bessi0_s=poly((x/3.75_sp)**2,p)
  else
     bessi0_s=(exp(ax)/sqrt(ax))*poly(3.75_sp/ax,q)
  end if
END FUNCTION bessi0_s

FUNCTION bessi0_v(x)
  use mo_kind
  use mo_nrutil, ONLY : poly
  IMPLICIT NONE
  REAL(SP), DIMENSION(:), INTENT(IN) :: x
  REAL(SP), DIMENSION(size(x)) :: bessi0_v
  REAL(SP), DIMENSION(size(x)) :: ax
  REAL(sp), DIMENSION(size(x)) :: y
  LOGICAL(LGT), DIMENSION(size(x)) :: mask
  REAL(sp), DIMENSION(7) :: p = (/1.0_sp,3.5156229_sp,&
       3.0899424_sp,1.2067492_sp,0.2659732_sp,0.360768e-1_sp,&
       0.45813e-2_sp/)
  REAL(sp), DIMENSION(9) :: q = (/0.39894228_sp,0.1328592e-1_sp,&
       0.225319e-2_sp,-0.157565e-2_sp,0.916281e-2_sp,&
       -0.2057706e-1_sp,0.2635537e-1_sp,-0.1647633e-1_sp,&
       0.392377e-2_sp/)
  ax=abs(x)
  mask = (ax < 3.75)
  where (mask)
     bessi0_v=poly((x/3.75_sp)**2,p,mask)
  elsewhere
     y=3.75_sp/ax
     bessi0_v=(exp(ax)/sqrt(ax))*poly(y,q,.not. mask)
  end where
END FUNCTION bessi0_v

FUNCTION dbessi0_s(x)
  use mo_kind
  use mo_nrutil, ONLY : poly
  IMPLICIT NONE
  REAL(DP), INTENT(IN) :: x
  REAL(DP) :: dbessi0_s
  REAL(DP) :: ax
  REAL(DP), DIMENSION(7) :: p = (/1.0_dp,3.5156229_dp,&
       3.0899424_dp,1.2067492_dp,0.2659732_dp,0.360768e-1_dp,&
       0.45813e-2_dp/)
  REAL(DP), DIMENSION(9) :: q = (/0.39894228_dp,0.1328592e-1_dp,&
       0.225319e-2_dp,-0.157565e-2_dp,0.916281e-2_dp,&
       -0.2057706e-1_dp,0.2635537e-1_dp,-0.1647633e-1_dp,&
       0.392377e-2_dp/)
  ax=abs(x)
  if (ax < 3.75) then
     dbessi0_s=poly(real((x/3.75_dp)**2,dp),p)
  else
     if (ax .lt. 709._dp) then
        dbessi0_s=(exp(ax)/sqrt(ax))*poly(real(3.75_dp/ax,dp),q)
     else
        dbessi0_s=(huge(1.0_dp)/sqrt(ax))*poly(real(3.75_dp/ax,dp),q)
     end if
  end if
END FUNCTION dbessi0_s

FUNCTION dbessi0_v(x)
  use mo_kind
  use mo_nrutil, ONLY : poly
  IMPLICIT NONE
  REAL(DP), DIMENSION(:), INTENT(IN) :: x
  REAL(DP), DIMENSION(size(x)) :: dbessi0_v
  REAL(DP), DIMENSION(size(x)) :: ax
  REAL(DP), DIMENSION(size(x)) :: y
  LOGICAL(LGT), DIMENSION(size(x)) :: mask
  REAL(DP), DIMENSION(7) :: p = (/1.0_dp,3.5156229_dp,&
       3.0899424_dp,1.2067492_dp,0.2659732_dp,0.360768e-1_dp,&
       0.45813e-2_dp/)
  REAL(DP), DIMENSION(9) :: q = (/0.39894228_dp,0.1328592e-1_dp,&
       0.225319e-2_dp,-0.157565e-2_dp,0.916281e-2_dp,&
       -0.2057706e-1_dp,0.2635537e-1_dp,-0.1647633e-1_dp,&
       0.392377e-2_dp/)
  ax=abs(x)
  mask = (ax < 3.75_dp)
  where (mask)
     dbessi0_v=poly(real((x/3.75_dp)**2,dp),p,mask)
  elsewhere
     y=3.75_dp/ax
     where (ax .lt. 709._dp)
        dbessi0_v=(exp(ax)/sqrt(ax))*poly(real(y,dp),q,.not. mask)
     elsewhere
        dbessi0_v=(huge(1.0_dp)/sqrt(ax))*poly(real(y,dp),q,.not. mask)
     end where
  end where
END FUNCTION dbessi0_v


program compute_pi
    use, intrinsic :: iso_fortran_env, only : i8 => INT64, r8 => REAL64
    use omp_lib
    implicit none
    integer(kind=i8), parameter :: nr_tries = 1000000_i8, &
                                   nr_blocks = 10
    integer(kind=i8) :: partial_nr_tries, i
    real(kind=r8) :: nr_success
    integer :: num_threads, thread_num
    num_threads = 1
    thread_num = 0
    nr_success = 0.0_r8
    !$omp parallel private(thread_num, i, partial_nr_tries)
        !$ num_threads = omp_get_num_threads()
        !$ thread_num = omp_get_thread_num()
        print '(2(A, I2))', 'thread ', thread_num, ' of ', num_threads
        partial_nr_tries = nr_tries/(num_threads*nr_blocks)
        !$omp do reduction (+:nr_success)
            do i = 1, num_threads*nr_blocks
                nr_success = nr_success + &
                                 compute_partial_pi(partial_nr_tries)
            end do
        !$omp end do
    !$omp end parallel
    print '(A, F15.8)', 'pi =', 4.0_r8*nr_success/(num_threads*nr_blocks)

    contains

        real(kind=r8) function compute_partial_pi(nr_tries)
            implicit none
            integer(kind=i8), intent(in) :: nr_tries
            real(kind=r8) :: nr_success, x, y
            integer(kind=i8) :: i
            nr_success = 0
            do i = 1_i8, nr_tries
                call random_number(x)
                call random_number(y)
                if (x**2 + y**2 < 1.0_r8) then
                    nr_success = nr_success + 1.0_r8
                end if
            end do
            compute_partial_pi = nr_success/nr_tries
        end function compute_partial_pi

end program compute_pi


module mpi_subs
    implicit none
    integer :: ierr, proc_id, proc_num

contains

    function calc_pi(n) result(pi)

        use mpi

        implicit none
        integer(8) :: accept, accept_part
        real(8) :: r(2), pi
        integer(8), intent(in) :: n
        integer(8) :: i

        accept = 0
        accept_part = 0

        do i = proc_id+1, n, proc_num
            call random_number(r)
            if (r(1)**2 + r(2)**2 <= 1) then
                accept_part = accept_part + 1
            end if
        end do

        call MPI_Barrier(MPI_COMM_WORLD, ierr)

        call MPI_Reduce(accept_part, accept, 1, MPI_INTEGER, MPI_SUM, 0, MPI_COMM_WORLD, ierr)
        pi = 4.0d0 * dble(accept)/dble(n)

    end function calc_pi

end module mpi_subs

program main

    use mpi
    use mpi_subs

    implicit none
    real(8) :: T1, T2, mypi
    real(8), parameter :: pi = 2.0d0*dacos(0.0d0)
    integer(8) :: n
    character (len=64) :: arg

    call MPI_Init(ierr)

    call MPI_Comm_rank(MPI_COMM_WORLD, proc_id, ierr)
    call MPI_Comm_size(MPI_COMM_WORLD, proc_num, ierr)

    if (command_argument_count() /= 1 .and. proc_id == 1) then
        error stop "One command line argument should be passed, which is the number of iterations to perform."
    end if

    call MPI_Barrier(MPI_COMM_WORLD, ierr)

    call get_command_argument(1, arg)
    read(arg,*) n

    call random_seed()
    call cpu_time(T1)
    mypi = calc_pi(n)

    call MPI_Finalize(ierr)
    call cpu_time(T2)
    if (proc_id == 0) then
        write(*,'(a,f12.6)') "Calculated = ", mypi
        write(*,'(a,f12.6)') "Actual =     ", pi
    end if
    print *, 'The time usage is:',  T2-T1

end program main


program test_gauss_sparse
    implicit none

!   explicit interface to the gauss_sparse function
    interface
        function gauss_sparse(num_iter, tol, b, A, x, actual_iter) result(tol_max)
           real ::  tol_max
           integer, intent(in) :: num_iter
           real, intent(in) :: tol
           real, intent(in), dimension(:) :: b, A(:,:)
           real, intent(inout) :: x(:)
           integer, optional, intent(out) :: actual_iter
        end function
    end interface

!   declare variables
    integer :: i, N = 3, actual_iter
    real :: residue
    real, allocatable :: A(:,:), x(:), b(:)

!   allocate arrays
    allocate (A(N, N), b(N), x(N))

!   Initialize matrix
    A = reshape([(real(i), i = 1, size(A))], shape(A))

!   Make matrix diagonally dominant
    do i = 1, size(A, 1)
        A(i,i) = sum(A(i,:)) + 1
    enddo

!   Initialize b
    b = [(i, i = 1, size(b))]

!   Initial (guess) solution
    x = b

!   invoke the gauss_sparse function
    residue = gauss_sparse(num_iter = 100, &
                           tol = 1E-5, &
                           b = b, &
                           A = a, &
                           x = x, &
                           actual_iter = actual_iter)

!   Output
    print '(/ "A = ")'
    do i = 1, size(A, 1)
        print '(100f6.1)', A(i,:)
    enddo

    print '(/ "b = " / (f6.1))', b

    print '(/ "residue = ", g10.3 / "iterations = ", i0 / "solution = "/ (11x, g10.3))', &
        residue, actual_iter, x

end program test_gauss_sparse


program ex6

    implicit none

    integer, parameter :: rk = selected_real_kind(15,300)

    real(rk) :: x, y
    real(rk) :: a, b, c

    x = 3.0_rk
    y = 4.0_rk

    print*, x**-y   ! --- Ok with some compilers
    print*, x**(-y) ! --- Correct expression

    a = 3.0_rk
    b = 2.0_rk
    c = 4.0_rk

    print*, -a+b+c
    print*, -a+b*c     ! --- Evaluates as ((-a)+(b*c))
    print*, (-a+b)*c
    print*, -(a+b)*c   ! --- Evaluates as -((a+b)*c)
    print*, -((a+b)*c)
    print*, a**b**c    ! --- Evaluates as a**(b**c)
    print*, a**(b**c)
    print*, (a**b)**c

    print*, 6/3
    print*, 8/3
    print*, -8/3

    print*, 2**3
    print*, 2**(-3)    ! --- = 1/(2**3)
    print*, 1/(2**3)
    print*, 2.0_rk**(-3.0_rk)

end program ex6


! CONTRACTIONS
! V9_d_v3           Contraction between 2nd order tensor and 1st order tensor
! V9_d_V9           Contraction between two 2nd order tensors with 9 components
! V9_dd_V9          Double contraction between two 2th order tensor of size (9)
! V9x9_dd_V9x9      Double contraction between two 4th order tensor of size (9,9)
! V9x9_dd_V9        Double contraction between a 4th order and a 2nd order tensor of size (9,9) and (9) respectively
! V9_dd_V9x9        Double contraction between a 2nd order and a 4th order tensor of size (9) and (9,9) respectively
! V9x9x9_dd_V9      Double contraction between a 6th order and a 2nd order tensor of size (9,9,9) and (9) respectively
!
! Special cases
! V9dV9dV9          Contraction between three 2nd order tensors with 9 components
! V9_d_V9x9         Single contraction between a 2nd and a 4th order tensor
! V9x9_d_V9         Single contraction between a 4th and a 2nd order tensor
!
! Operations on ordinary matrices
! M_x_ve            Multiplication between a matrix and vector
! ve_x_M            Multiplication between a vector and matrix

Module Contractions
use Conversions

Implicit none
    CONTAINS

!==============================================================================
FUNCTION V9_d_v3(a,b) RESULT (c)
Implicit none

    INTEGER i,j
    DOUBLE PRECISION, INTENT (IN) :: a(9),b(3)
    DOUBLE PRECISION :: c(3)
!                              |1 4 7|
!   [1 2 3 4 5 6 7 8 9]   =>   |8 2 5|
!                              |6 9 3|
    c(1)=a(1)*b(1)+a(4)*b(2)+a(7)*b(3)
    c(2)=a(8)*b(1)+a(2)*b(2)+a(5)*b(3)
    c(3)=a(6)*b(1)+a(9)*b(2)+a(3)*b(3)

END FUNCTION
!==============================================================================

!==============================================================================
FUNCTION V9_d_V9(a,b) RESULT (c)
Implicit none

    INTEGER i,j
    DOUBLE PRECISION, INTENT (IN) :: a(9),b(9)
    DOUBLE PRECISION :: c(9)

    c(1)=a(1)*b(1) + a(7)* b(6) + a(4)* b(8)
    c(2)=a(2)*b(2) + a(8)* b(4) + a(5)* b(9)
    c(3)=a(3)*b(3) + a(9)* b(5) + a(6)* b(7)
    c(4)=a(4)*b(2) + a(1)* b(4) + a(7)* b(9)
    c(5)=a(5)*b(3) + a(2)* b(5) + a(8)* b(7)
    c(6)=a(6)*b(1) + a(3)* b(6) + a(9)* b(8)
    c(7)=a(7)*b(3) + a(4)* b(5) + a(1)* b(7)
    c(8)=a(8)*b(1) + a(5)* b(6) + a(2)* b(8)
    c(9)=a(9)*b(2) + a(6)* b(4) + a(3)* b(9)

END FUNCTION
!==============================================================================

!==============================================================================
FUNCTION V9_dd_V9(a,b) RESULT (c)
Implicit none
    DOUBLE PRECISION, INTENT (IN) :: a(9),b(9)
    DOUBLE PRECISION :: c

    !c=tr_V9(V9_d_V9(trans_V9(a),b))
    c = sum(a*b)

END FUNCTION
!==============================================================================

!==============================================================================
FUNCTION V9x9_dd_V9x9(a,b) RESULT (c)
Implicit none
! Did a comparison between looping manually(1), matmul(2) and dgemm(3) for 10^6 calls
! (1) ~14.6s
! (2) ~ 8.5s
! (3) ~ 1.4s
! Clearly, dgemm should be used as much as possible for 9x9.
! Knut Andreas Meyer, 2017-02-08
!
      DOUBLE PRECISION, INTENT (IN) :: a(9,9),b(9,9)
      DOUBLE PRECISION :: c(9,9)
      INTEGER I,J,K
!      c = 0.d0
!      do I=1,9
!        do K=1,9
!          do J=1,9
!            c(I,K)=c(I,K)+a(I,J)*b(J,K)
!          enddo
!        enddo
!      enddo
      call dgemm('N','N', 9, 9, 9, 1.d0,a, 9, b, 9, 0.d0, c, 9)

END FUNCTION
!==============================================================================

!==============================================================================
FUNCTION V9x9_dd_V9(a,b) RESULT (c)
Implicit none

      DOUBLE PRECISION,INTENT(IN)::a(9,9),b(9)
      DOUBLE PRECISION::c(9)
      INTEGER I,J
!      c=(/0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0/);
!      do I=1,9
!        do J=1,9
!            c(I)=c(I)+a(I,J)*b(J)
!        enddo
!      enddo
      call dgemv('N', 9, 9, 1.d0, a, 9, b, 1, 0.d0, c, 1)

END FUNCTION
!==============================================================================

!==============================================================================
FUNCTION V9_dd_V9x9(a,b) RESULT (c)
Implicit none

      DOUBLE PRECISION, INTENT (IN) :: a(9),b(9,9)
      DOUBLE PRECISION              :: c(9)
      INTEGER I,K
      !c=(/0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,0.d0/);
      !do K=1,9;do I=1,9;c(K)=c(K)+a(I)*b(I,K);enddo;enddo

      call dgemv('T', 9, 9, 1.d0, b, 9, a, 1, 0.d0, c, 1)

END FUNCTION
!==============================================================================

!==============================================================================
FUNCTION V9x9x9_dd_V9(a,b) RESULT (c)
!==============================================================================
! Purpose: 6th order tensor double contracted with a 2nd order tensor
!
! Written by: Nasim Larijani
!
! Function that makes c_mnkl = a_mnpqkl * b_pq, NL 2011 Nov 15
!==============================================================================
Implicit none

      DOUBLE PRECISION, INTENT (IN) :: a(9,9,9),b(9)
      DOUBLE PRECISION              :: c(9,9)
      INTEGER M,K,P

      do M=1,9
        do K=1,9
              c(M,K)=0.d0
              do P=1,9
                    c(M,K)=c(M,K)+a(M,P,K)*b(P)
              enddo
        enddo
      enddo

END FUNCTION
!==============================================================================

!! Special contractions
!==============================================================================
FUNCTION V9dV9dV9(a,b,c) RESULT (d)
! Old name: us_9d9d9
implicit none

      DOUBLE PRECISION, INTENT (IN) :: a(9),b(9),c(9)
      DOUBLE PRECISION :: d(9)
      d=V9_d_V9(a,V9_d_V9(b,c))

END FUNCTION
!==============================================================================

!==============================================================================
FUNCTION V9_d_V9x9(a,b) RESULT (c)
Implicit none

      DOUBLE PRECISION,INTENT(IN)   :: a(9), b(9,9)
      DOUBLE PRECISION              :: c(9,9)
      DOUBLE PRECISION              :: a_2(3,3), b_4(3,3,3,3), c_4(3,3,3,3)
      INTEGER i, j, k, l

      c_4 = 0.d0

      ! Convert to a real fouth order tensor
      b_4 = V9x9_2_T4(b)
      a_2 = V9_2_M(a)

      Do i=1,3
        Do j=1,3
          Do k=1,3
            Do l=1,3

                c_4(i,j,k,l) = sum(a_2(i,1:3)*b_4(1:3,j,k,l))

            End do
          End do
        End do
      End do

    ! Convert back to Voigt format
    c = T4_2_V9x9(c_4)

END FUNCTION
!==============================================================================

!==============================================================================
FUNCTION V9x9_d_V9(b, a) RESULT (c)
Implicit none

      DOUBLE PRECISION,INTENT(IN)   :: a(9), b(9,9)
      DOUBLE PRECISION              :: c(9,9)
      DOUBLE PRECISION              :: a_2(3,3), b_4(3,3,3,3), c_4(3,3,3,3)
      INTEGER i, j, k, l

      c_4 = 0.d0

      ! Convert to a real fouth order tensor
      b_4 = V9x9_2_T4(b)
      a_2 = V9_2_M(a)

      Do i=1,3
        Do j=1,3
          Do k=1,3
            Do l=1,3

                c_4(i,j,k,l) = sum( b_4(i,j,k,1:3)*a_2(1:3,l) )

            End do
          End do
        End do
      End do

    ! Convert back to Voigt format
    c = T4_2_V9x9(c_4)

END FUNCTION
!==============================================================================

!! Ordinary matrix operations (should perhaps update function and issue warning saying to use built in functions)?
!==============================================================================
FUNCTION M_x_ve(a,b) RESULT (c)
! Old name: us_matrix_m_vector
Implicit none

    DOUBLE PRECISION, INTENT (IN) :: a(:,:)
    DOUBLE PRECISION, INTENT (IN) :: b(:)
    DOUBLE PRECISION              :: c(size(b))

    INTEGER I,J
    DO I=1,SIZE(b)
       c(I)=0.d0
       DO J=1,SIZE(b)
          c(I)=c(I)+a(I,J)*b(j)
       ENDDO
    ENDDO

END FUNCTION
!==============================================================================

!==============================================================================
FUNCTION ve_x_M(b,a) RESULT (c)
Implicit none

    DOUBLE PRECISION, DIMENSION(:), INTENT (IN) :: b
    DOUBLE PRECISION, DIMENSION(:,:), INTENT (IN) :: a
    DOUBLE PRECISION, DIMENSION(SIZE(b)) :: c
    INTEGER I,J

    DO I=1,SIZE(b)
       c(I)=0.d0
       DO J=1,SIZE(b)
          c(I)=c(I)+a(j,i)*b(j)
       ENDDO
    ENDDO

END FUNCTION
!==============================================================================

END MODULE


!##############################################################################
! PROGRAM simulation
!
! ## Simulation of realizations of random variables
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program simulation

    use toolbox

    implicit none
    integer, parameter :: NN = 20000
    real*8 :: x(0:NN)
    real*8 :: a, b, mu, sigma, alpha, beta, p, q
    integer :: n

    ! uniform distribution
    a = -1d0
    b = 1d0
    call simulate_uniform(x, a, b)
    call plot_hist(x, 20)
    call execplot(title="Uniform Distribution")

    ! normal distribution
    mu = 1d0
    sigma = 0.25d0
    call simulate_normal(x, mu, sigma)
    call plot_hist(x, 20, left=mu-3d0*sqrt(sigma), right=mu+3d0*sqrt(sigma))
    call execplot(title="Normal Distribution")

    ! log-normal distribution
    mu = 1d0
    sigma = 0.25d0
    call simulate_log_normal(x, mu, sigma)
    call plot_hist(x, 20, left=0d0, right=mu+5d0*sqrt(sigma))
    call execplot(title="Log-Normal Distribution")

    ! Gamma distribution
    alpha = 2d0
    beta = 1.25d0
    call simulate_Gamma(x, alpha, beta)
    call plot_hist(x, 20)
    call execplot(title="Gamma Distribution")

    ! beta distribution
    p = 2d0
    q = 5d0
    call simulate_beta(x, p, q)
    call plot_hist(x, 20)
    call execplot(title="beta Distribution")

    ! bernoulli distribution
    p = 0.25d0
    call simulate_bernoulli(x, p)
    call plot_hist(x, 2)
    call execplot(title="Bernoulli Distribution")

    ! binomial distribution
    p = 0.25d0
    n = 12
    call simulate_binomial(x, n, p)
    call plot_hist(x, n+1, left=-0.5d0, right=dble(n)+0.5d0)
    call execplot(title="Binomial Distribution")

end program


PROGRAM primes_omp
  USE omp_lib
  IMPLICIT NONE
  INTEGER(kind=8) ::  i, Nprimes
  REAL(kind=8) :: start_t, end_t
  LOGICAL, ALLOCATABLE :: primes(:)
  INTEGER, PARAMETER :: limit = 500000000

  start_t = omp_get_wtime()

  ! Initialise
  ALLOCATE(primes(limit))
  primes=.true.
  primes(1)=.false.

  ! Sieve of Eratosthenes

  !$OMP PARALLEL DEFAULT(none)    &
  !$OMP SHARED(primes,Nprimes)
  !$OMP DO SCHEDULE(static)
  DO i=2,limit
     IF (primes(i)) THEN
        primes(i*i : limit : i) = .false.
     END IF
  END DO
  !$OMP END DO

  ! Count up number of primes
  Nprimes=0
  !$OMP DO SCHEDULE(static) REDUCTION(+:Nprimes)
  DO i=1,limit
     IF (primes(i)) Nprimes = Nprimes+1
  END DO
  !$OMP END DO
  !$OMP END PARALLEL

  end_t = omp_get_wtime()

  WRITE(*,*) "Number of primes = ",Nprimes
  WRITE(*,*) "Expended wall clock time = ",end_t-start_t

END PROGRAM primes_omp


! $UWHPSC/codes/fortran/arrayops.f90

program arrayops

    implicit none
    real(kind=8), dimension(3,2) :: a
    real(kind=8), dimension(2,3) :: b
    real(kind=8), dimension(3,3) :: c
    real(kind=8), dimension(2) :: x
    real(kind=8), dimension(3) :: y
    integer i

    a = reshape((/1,2,3,4,5,6/), (/3,2/))

    print *, "a = "
    do i=1,3
        print *, a(i,:)   ! i'th row
        enddo

    b = transpose(a)

    print *, "b = "
    do i=1,2
        print *, b(i,:)   ! i'th row
        enddo

    c = matmul(a,b)
    print *, "c = "
    do i=1,3
        print *, c(i,:)   ! i'th row
        enddo

    x = (/5,6/)
    y = matmul(a,x)
    print *, "x = ",x
    print *, "y = ",y

end program arrayops


! SELF_Quadrature.f90
!
! Copyright 2020 Fluid Numerics LLC
! Author : Joseph Schoonover (joe@fluidnumerics.com)
! Support : self@higherordermethods.org
!
! //////////////////////////////////////////////////////////////////////////////////////////////// !
!
! Contains routines from D.A. Kopriva, 2009, "Implementing Spectral Methods for Partial
! Differential Equations: Algorithms for Scientists and Engineers", Springer.
!
! Routines are defined for computing Legendre and Chebyshev Gauss and Gauss-Lobatto
! quadrature nodes and weights.

MODULE SELF_Quadrature

  USE ISO_FORTRAN_ENV
  USE SELF_Constants

  IMPLICIT NONE

  PUBLIC  :: ChebyshevQuadrature,LegendreQuadrature
  PRIVATE :: ChebyshevGauss,ChebyshevGaussLobatto, &
             LegendreGauss,LegendreGaussLobatto, &
             LegendreQandL

CONTAINS

! =============================================================================================== !
! LegendreQuadrature
!   Returns the specified Legendre quadrature nodes and integration weights.
!
!   Given a polynomial degree, and quadrature type (Gauss or Gauss Lobatto), this subroutine manages
!   the calls to underlying private routines to generate the desired Legendre quadrature.
!
!   Usage :
!
!     INTEGER    :: N, quadType
!     REAL(real64) :: nodes(0:N), weights(0:N)
!
!       CALL LegendreQuadrature( N, quadType, nodes, weights )
!
!   Parameters :
!
!     N (in)
!       Degree of the quadrature
!
!     quadType (in)
!       Flag specifying the quadrature type. Can be set to GAUSS or GAUSS_LOBATTO
!
!     nodes(0:N) (out)
!       Array of quadrature nodes
!
!     weights(0:N) (out)
!       Array of quadrature weights
!
! =============================================================================================== !

  SUBROUTINE LegendreQuadrature(N,nodes,weights,QuadType)
    IMPLICIT NONE
    INTEGER,INTENT(in)     :: N
    REAL(prec),INTENT(out) :: nodes(0:N)
    REAL(prec),INTENT(out) :: weights(0:N)
    INTEGER,INTENT(in)     :: QuadType
    ! Local
    REAL(real64) :: nodesLocal(0:N)
    REAL(real64) :: weightsLocal(0:N)
    INTEGER :: i

    IF (QuadType == GAUSS_LOBATTO) THEN

      CALL LegendreGaussLobatto(N,nodesLocal,weightsLocal)

    ELSEIF (QuadType == GAUSS) THEN

      CALL LegendreGauss(N,nodesLocal,weightsLocal)

    END IF

    DO i = 0,N
      nodes(i) = REAL(nodesLocal(i),prec)
      weights(i) = REAL(weightsLocal(i),prec)
    END DO

  END SUBROUTINE LegendreQuadrature

! =============================================================================================== !
! ChebyshevQuadrature
!
!   Returns the specified Chebyshev quadrature nodes and integration weights.
!
!   Given a polynomial degree, and quadrature type (Gauss or Gauss Lobatto), this subroutine manages
!   the calls to underlying private routines to generate the desired Chebyshev quadrature.
!
!   Usage :
!
!     INTEGER    :: N, quadType
!     REAL(real64) :: nodes(0:N), weights(0:N)
!
!       CALL ChebyshevQuadrature( N, quadType, nodes, weights )
!
!   Input/Output :
!
!     N (in)
!       Degree of the quadrature
!
!     quadType (in)
!       Flag specifying the quadrature type. Can be set to GAUSS or GAUSS_LOBATTO
!
!     nodes(0:N) (out)
!       Array of quadrature nodes
!
!     weights(0:N) (out)
!       Array of quadrature weights
!
! ================================================================================================ !

  SUBROUTINE ChebyshevQuadrature(N,nodes,weights,quadType)
    IMPLICIT NONE
    INTEGER,INTENT(in)     :: N
    REAL(prec),INTENT(out) :: nodes(0:N)
    REAL(prec),INTENT(out) :: weights(0:N)
    INTEGER,INTENT(in)     :: QuadType
    ! Local
    REAL(real64) :: nodesLocal(0:N)
    REAL(real64) :: weightsLocal(0:N)
    INTEGER :: i

    IF (QuadType == CHEBYSHEV_GAUSS_LOBATTO) then

      CALL ChebyshevGaussLobatto(N,nodesLocal,weightsLocal)

    ELSEIF (QuadType == CHEBYSHEV_GAUSS) then

      CALL ChebyshevGauss(N,nodesLocal,weightsLocal)

    END IF

    DO i = 0,N
      nodes(i) = REAL(nodesLocal(i),prec)
      weights(i) = REAL(weightsLocal(i),prec)
    END DO

  END SUBROUTINE ChebyshevQuadrature

! =============================================================================================== !
! S/R ChebyshevGauss
!   From Kopriva (2009) "Implementing Spectral Methods for Partial Differential Equations", p. 67
!   Algorithm 26
! =============================================================================================== !

  SUBROUTINE ChebyshevGauss(N,nodes,weights)
    IMPLICIT NONE
    INTEGER       :: N
    REAL(real64)    :: nodes(0:N)
    REAL(real64)    :: weights(0:N)
    ! Local
    INTEGER    :: j

    DO j = 0,N

      weights(j) = pi/(REAL(N,real64) + 1.0_real64)
      nodes(j) = -cos(pi*(2.0_real64*REAL(j,real64) + 1.0_real64)/(2.0_real64*REAL(N,real64)+2.0_real64))

    END DO

  END SUBROUTINE ChebyshevGauss

! =============================================================================================== !
! S/R ChebyshevGaussLobatto
!   From Kopriva (2009) "Implementing Spectral Methods for Partial Differential Equations", p. 68
!   Algorithm 27
! =============================================================================================== !

  SUBROUTINE ChebyshevGaussLobatto(N,nodes,weights)
    IMPLICIT NONE
    INTEGER       :: N
    REAL(real64)    :: nodes(0:N)
    REAL(real64)    :: weights(0:N)
    ! LOCAL
    INTEGER    :: j

    DO j = 0,N

      weights(j) = pi/REAL(N,real64)
      nodes(j) = -cos(pi*REAL(j,real64)/REAL(N,real64))

    END DO

    weights(0) = weights(0)*0.5_real64
    weights(N) = weights(N)*0.5_real64

  END SUBROUTINE ChebyshevGaussLobatto

! =============================================================================================== !
! S/R LegendreGauss
!   From Kopriva (2009) "Implementing Spectral Methods for Partial Differential Equations", p. 64
!   Algorithm 23
! =============================================================================================== !

  SUBROUTINE LegendreGauss(N,nodes,weights)
    IMPLICIT NONE
    INTEGER    :: N
    REAL(real64) :: nodes(0:N)
    REAL(real64) :: weights(0:N)
    ! Local
    REAL(real64) :: nodes_local(0:N)
    REAL(real64) :: weights_local(0:N)
    REAL(real64) :: lN1,dlN1
    REAL(real64) :: delta
    INTEGER  :: j,kIt

    IF (N == 0) then

      nodes_local(0) = 0.0_real64
      weights_local(0) = 2.0_real64

    ELSEIF (N == 1) then

      nodes_local(0) = -SQRT(1.0_real64/3.0_real64)
      weights_local(0) = 1.0_real64
      nodes_local(1) = -nodes(0)
      weights_local(1) = weights(0)

    ELSE

      DO j = 0, ((N + 1)/2)

        nodes_local(j) = -cos((2.0_real64*REAL(j,real64) + 1.0_real64)*pi/(2.0_real64*REAL(N,real64) + 1.0_real64))

        DO kIt = 1,newtonMax

          CALL LegendrePolynomial(N + 1,nodes_local(j),lN1,dlN1)
          delta = -lN1/dlN1
          nodes_local(j) = nodes_local(j) + delta
          IF (abs(delta) <= TOL*nodes_local(j)) EXIT

        END DO

        CALL LegendrePolynomial(N + 1,nodes_local(j),lN1,dlN1)
        weights_local(j) = 2.0_real64/((1.0_real64 - nodes_local(j)*nodes_local(j))*dlN1*dlN1)
        weights_local(N - j) = weights_local(j)
        nodes_local(N - j) = -nodes_local(j)

      END DO

    END IF

    IF (MOD(REAL(N,real64),2.0_real64) == 0.0_real64) then

      CALL LegendrePolynomial(N + 1,0.0_real64,lN1,dlN1)
      nodes_local(N/2) = 0.0_real64
      weights_local(N/2) = 2.0/(dlN1*dlN1)

    END IF

    DO j = 0,N
      nodes(j) = REAL(nodes_local(j),real64)
      weights(j) = REAL(weights_local(j),real64)
    END DO

  END SUBROUTINE LegendreGauss

  ! =============================================================================================== !
  ! S/R LegendreGaussLobatto
  !   From Kopriva (2009) "Implementing Spectral Methods for Partial Differential Equations", p. 66
  !   Algorithm 25
  ! =============================================================================================== !

  SUBROUTINE LegendreGaussLobatto(N,nodes,weights)
    IMPLICIT NONE
    INTEGER    :: N
    REAL(real64) :: nodes(0:N)
    REAL(real64) :: weights(0:N)
    ! Local
    REAL(real64) :: nodes_local(0:N)
    REAL(real64) :: weights_local(0:N)
    REAL(real64) :: delta,q,qprime,lN
    INTEGER  :: j,kIt

    IF (N == 1) then

      nodes_local(0) = -1.0_real64
      weights_local(0) = 1.0_real64
      nodes_local(1) = 1.0_real64
      weights_local(1) = 1.0_real64

    ELSE

      nodes_local(0) = -1.0_real64
      weights_local(0) = 2.0_real64/(REAL(N,real64)*(REAL(N,real64) + 1.0_real64))
      nodes_local(N) = 1.0_real64
      weights_local(N) = weights_local(0)

      DO j = 1, ((N + 1)/2 - 1)

        nodes_local(j) = -COS((REAL(j,real64) + 0.25_real64)*pi/REAL(N,real64) - &
                              3.0_real64/(8.0_real64*REAL(N,real64)*pi*(REAL(j,real64) + 0.25_real64)))

        DO kIt = 1,newtonMax

          CALL LegendreQandL(N,nodes_local(j),q,qprime,lN)

          delta = -q/qprime
          nodes_local(j) = nodes_local(j) + delta
          IF (ABS(delta) <= TOL*nodes_local(j)) EXIT

        END DO

        CALL LegendreQandL(N,nodes_local(j),q,qprime,lN)

        weights_local(j) = 2.0_real64/(REAL(N,real64)*(REAL(N,real64) + 1.0_real64)*lN*lN)
        weights_local(N - j) = weights_local(j)
        nodes_local(N - j) = -nodes_local(j)

      END DO

    END IF

    IF (MOD(REAL(N,real64),2.0_real64) == 0.0_real64) THEN

      CALL LegendreQandL(N,0.0_real64,q,qprime,lN)

      nodes_local(N/2) = 0.0_real64
      weights_local(N/2) = 2.0_real64/(REAL(N,real64)*(REAL(N,real64) + 1.0_real64)*lN*lN)

    END IF

    DO j = 0,N
      nodes(j) = REAL(nodes_local(j),real64)
      weights(j) = REAL(weights_local(j),real64)
    END DO

  END SUBROUTINE LegendreGaussLobatto

! =============================================================================================== !
! S/R LegendrePolynomial
!   From Kopriva (2009) "Implementing Spectral Methods for Partial Differential Equations", p. 63
!   Algorithm 22
! =============================================================================================== !

  SUBROUTINE LegendrePolynomial(N,x,lAtX,dLdxAtX)
    IMPLICIT NONE
    INTEGER     :: N
    REAL(real64)    :: x
    REAL(real64)    :: lAtX,dLdxAtX
    ! Local
    REAL(real64) :: lNm1,lNm2,dlNm1,dlNm2
    INTEGER  :: i

    IF (N == 0) then

      lAtX = 1.0_real64
      dLdxAtX = 0.0_real64

    ELSEIF (N == 1) then

      lAtX = x
      dLdxAtX = 1.0_real64

    ELSE

      lnM2 = 1.0_real64
      lnM1 = x
      dlnM2 = 0.0_real64
      dlnM1 = 1.0_real64

      DO i = 2,N

        lAtX = ((2.0_real64*REAL(i,real64) - 1.0_real64)*x*lnM1 - &
                (REAL(i,real64) - 1.0_real64)*lnM2)/(REAL(i,real64))

        dldxAtX = dlnM2 + (2.0_real64*REAL(i,real64) - 1.0_real64)*lnM1
        lnM2 = lnM1
        lnM1 = lAtX
        dlnM2 = dlnM1
        dlnM1 = dldxAtX

      END DO

    END IF

  END SUBROUTINE LegendrePolynomial

! =============================================================================================== !
! S/R LegendreQandL
!   From Kopriva (2009) "Implementing Spectral Methods for Partial Differential Equations", p. 65
!   Algorithm 24
! =============================================================================================== !

  SUBROUTINE LegendreQandL(N,x,q,qprime,lN)
    IMPLICIT NONE
    INTEGER    :: N
    REAL(real64) :: x
    REAL(real64) :: lN,q,qprime
    ! Local
    REAL(real64) :: lNm1,lNm2,dlNm1,dlNm2,dlN,lN1,dlN1
    INTEGER    :: i

    lNm2 = 1.0_real64
    lNm1 = x
    dlNm2 = 0.0_real64
    dlNm1 = 1.0_real64

    DO i = 2,N

      lN = (2.0_real64*i - 1.0_real64)/(REAL(i,real64))*x*lNm1 - (REAL(i,real64) - 1.0_real64)/(REAL(i,real64))*lNm2
      dlN = dlNm2 + (2.0_real64*REAL(i,real64) - 1.0_real64)*lNm1
      lNm2 = lNm1
      lNm1 = lN
      dlNm2 = dlNm1
      dlNm1 = dlN

    END DO

    i = N + 1
    lN1 = (2.0_real64*i - 1.0_real64)/(REAL(i,real64))*x*lN - (REAL(i,real64) - 1.0_real64)/(REAL(i,real64))*lNm2
    dlN1 = dlNm2 + (2.0_real64*REAL(i,real64) - 1.0_real64)*lNm1
    q = lN1 - lNm2
    qprime = dlN1 - dlNm2

  END SUBROUTINE LegendreQandL

END MODULE SELF_Quadrature


! 6.2e в учебнике

program ex_6_2e
   implicit none

   integer, parameter      :: R_ = 16
   real(R_)                :: x = 0, a = 0, currentElement = 0, currentSum = 0, newSum = 0, numeratorDiff = 0
   integer                 :: In = 0, Out = 0, i = 0
   character(*), parameter :: output_file = "output.txt", input_file = "../data/input.txt"

   open (file=input_file, newunit=In)
      read(In,'(f5.2)') a
      read(In,'(f5.2)') x
   close (In)

   currentElement = 1
   newSum = 1
   numeratorDiff = x * log(a)

   do
      i = i + 1
      currentSum = newSum

      currentElement = currentElement * numeratorDiff / i

      newSum = currentSum + currentElement
      if (currentSum == newSum) exit
   end do

   open (file=output_file, newunit=Out)
      write(Out, '(f5.2,a,f5.2)') currentSum, ' ~ ' , a**x
   close (Out)

end program ex_6_2e


      subroutine exponential(s,p1,p2,p3,p4,r,dr,rn,drn)
!***********************************************************************
! Copyright 2009 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 Exponential relative permeability and capillary pressure model.
!D1
!***********************************************************************
c     input:  s saturation of wetting phase
c     p1 residual sat of wetting phase
c     p2 max sat of wetting phase
c     p3 = exponent
c     p4 = multiplier
c     return:  r (wetting phase), rn (non-wetting phase), and derivatives
c     with respect to wetting phase

      implicit none
      real*8 s,p1,p2,p3,r,dr,star,p4,rn,drn
      r=0;dr=0
      if(s.ge.p1.and.s.le.p2) then
         star=(s-p1)/(p2-p1)
         r= p4*star**p3
         dr = p4*p3*star**(p3-1.0)/(p2-p1)
	 rn=p4*(1.-star)**p3
         drn= -1.*p4*p3*(1.-star)**(p3-1.0)/(p2-p1)
      elseif (s.gt.p2) then
         r=1.
         dr=0
         rn=0.
         drn=0.
      elseif (s.lt.p1) then
         r=0
         dr=0
         rn=1.
         drn=0.
      endif

      end subroutine exponential


module fornberg

  implicit none

  integer, parameter :: dp=kind(0.d0)  ! double precision

  private
  public apply_fd, populate_weights

contains

  subroutine apply_fd(nin, maxorder, xdata, ydata, xtgt, out)
    integer, intent(in)    :: nin, maxorder
    real(dp), intent(in)    :: xdata(0:), ydata(0:), xtgt
    real(dp), intent(out) :: out(0:)

    integer :: j
    real(dp) :: c(0:nin-1, 0:maxorder)

    call populate_weights(xtgt, xdata, nin-1, maxorder, c)
    forall(j=0:maxorder) out(j) = sum(c(:, j)*ydata)
  end subroutine

  subroutine populate_weights(z, x, nd, m, c)
    !
    !  Input Parameters
    !    z            -  location where approximations are to be
    !                    accurate
    !    x(0:nd)      -  grid point locations, found in x(0:n)
    !    nd           -  dimension of x- and c-arrays in calling
    !                    program x(0:nd) and c(0:nd, 0:m), respectively
    !    m            -  highest derivative for which weights are
    !                    sought
    !
    !  Output Parameter
    !    c(0:nd,0:m)  -  weights at grid locations x(0:n) for
    !                    derivatives of order 0:m, found in c(0:nd, 0:m)
    !
    !  References:
    !      Generation of Finite Difference Formulas on Arbitrarily
    !          Spaced Grids, Bengt Fornberg,
    !          Mathematics of compuation, 51, 184, 1988, 699--706,
    !          doi: 10.1090/S0025-5718-1988-0935077-0
    !
    !      Classroom note: Calculation of weights in finite
    !          difference formulas, Bengt Fornberg,
    !          SIAM review, 40, 3, 1998, 685--691,
    !          doi: 10.1137/S0036144596322507

    real(dp), intent(in)    :: z
    integer,  intent(in)    :: nd, m
    real(dp), intent(in)    :: x(0:nd)
    real(dp), intent(out)   :: c(0:nd, 0:m)

    real(dp) :: c1, c2, c3, c4, c5
    integer  :: i, j, k, mn

    c1 = 1
    c4 = x(0) - z
    c = 0
    c(0, 0) = 1
    do i=1, nd
      mn = min(i, m)
      c2 = 1
      c5 = c4
      c4 = x(i) - z
      do j=0, i-1
        c3 = x(i) - x(j)
        c2 = c2*c3
        if (j == i-1) then
          do k = mn, 1, -1
            c(i, k) = c1*(k*c(i-1, k-1) - c5*c(i-1, k))/c2
          end do
          c(i, 0) = -c1*c5*c(i-1, 0)/c2
        endif
        do k=mn, 1, -1
          c(j, k) = (c4*c(j, k) - k*c(j, k-1))/c3
        end do
        c(j, 0) = c4*c(j, 0)/c3
      end do
      c1 = c2
    end do
  end subroutine

end module


subroutine strcub(pnode,npoin,kpoin,lpoin,lnods,strea)

!-----------------------------------------------------------------------
!****f* Mathru/strcub
! NAME
!    strcub
! DESCRIPTION
!    This routine computes the stream-function at the interior points of
!    the 16-noded cubic quadrilateral and the 10-noded cubic triangle
! USES
! USED BY
!    strloc
!***
!-----------------------------------------------------------------------
!  use      def_kintyp
  use   typre
  implicit none
  integer(ip), intent(in)    :: pnode,npoin
  integer(ip), intent(in)    :: lnods(pnode)
  integer(ip), intent(inout) :: lpoin(npoin),kpoin
  real(rp),    intent(inout) :: strea(npoin)
  integer(ip)                :: inode,ipoin,ipo10
  real(rp)                   :: contr
  real(rp)                   :: strlo(12)
!
! 16-noded element
!
  if(pnode==16) then
     do inode=1,12
        ipoin=lnods(inode)
        strlo(inode)=strea(ipoin)/real(lpoin(ipoin))
     end do
     strea(lnods(13))=strlo(12)+strlo( 5)-strlo(1)
     strea(lnods(14))=strlo( 6)+strlo( 7)-strlo(2)
     strea(lnods(15))=strlo( 8)+strlo( 9)-strlo(3)
     strea(lnods(16))=strlo(10)+strlo(11)-strlo(4)
     lpoin(lnods(13))=lpoin(lnods(13))+1
     lpoin(lnods(14))=lpoin(lnods(14))+1
     lpoin(lnods(15))=lpoin(lnods(15))+1
     lpoin(lnods(16))=lpoin(lnods(16))+1
     kpoin = kpoin + 4
!
! 10-noded element
!
  else if(pnode==10) then
     ipo10=lnods(10)
     strea(ipo10)=0.0
     do inode=1,3
        ipoin=lnods(inode)
        contr=strea(ipoin)/float(lpoin(ipoin))
        strea(ipo10)=strea(ipo10)-contr
     end do
     do inode=4,9
        ipoin=lnods(inode)
        contr=strea(ipoin)/float(lpoin(ipoin))
        strea(ipo10)=strea(ipo10)+contr
     end do
     strea(ipo10)=strea(ipo10)/3.0
     lpoin(ipo10)=lpoin(ipo10)+1
     kpoin = kpoin + 1
  end if

end subroutine strcub


      SUBROUTINE RETARD(N,FCN,X,Y,XEND,
     &                  RTOL,ATOL,ITOL,
     &                  SOLOUT,IOUT,
     &                  WORK,LWORK,IWORK,LIWORK,LRCONT,LICONT,
     &                  RPAR,IPAR,IDID)
C ----------------------------------------------------------
C     NUMERICAL SOLUTION OF A SYSTEM OF FIRST 0RDER DELAY
C     ORDINARY DIFFERENTIAL EQUATIONS  Y'(X)=F(X,Y(X),Y(X-A),...).
C     THIS CODE IS BASED ON AN EXPLICIT RUNGE-KUTTA METHOD OF
C     ORDER (4)5 DUE TO DORMAND & PRINCE (WITH STEPSIZE CONTROL
C     AND DENSE OUTPUT).
C
C     AUTHORS: E. HAIRER AND G. WANNER
C              UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES
C              CH-1211 GENEVE 24, SWITZERLAND
C              E-MAIL:  Ernst.Hairer@math.unige.ch
C                       Gerhard.Wanner@math.unige.ch
C
C     THIS CODE IS DESCRIBED IN SECTION II.17 OF THE BOOK:
C         E. HAIRER, S.P. NORSETT AND G. WANNER, SOLVING ORDINARY
C         DIFFERENTIAL EQUATIONS I. NONSTIFF PROBLEMS. 2ND EDITION.
C         SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS,
C         SPRINGER-VERLAG (1993)
C
C     VERSION OF SEPTEMBER 30, 1995
C
C     INPUT PARAMETERS
C     ----------------
C     N           DIMENSION OF THE SYSTEM
C
C     FCN         NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE RIGHT-
C                 HAND-SIDE OF THE DELAY EQUATION, E.G.,
C                    SUBROUTINE FCN(N,X,Y,F,RPAR,IPAR)
C                    DOUBLE PRECISION X,Y(N),F(N)
C                    EXTERNAL PHI
C                    F(1)=(1.4D0-YLAG(1,X-1.D0,PHI,RPAR,IPAR))*Y(1)
C                    F(2)=...   ETC.
C                 FOR AN EXPLICATION OF YLAG SEE BELOW.
C                 DO NOT USE YLAG(I,X-0.D0,PHI,RPAR,IPAR) !
C                 THE INITIAL FUNCTION HAS TO BE SUPPLIED BY:
C                    FUNCTION PHI(I,X,RPAR,IPAR)
C                    DOUBLE PRECISION PHI,X
C                 WHERE I IS THE COMPONENT AND X THE ARGUMENT
C
C     X           INITIAL X-VALUE
C
C     Y(N)        INITIAL VALUES FOR Y (MAY BE DIFFERENT FROM PHI (I,X),
C                 IN THIS CASE IT IS HIGHLY RECOMMENDED TO SET IWORK(6)
C                 AND WORK(21),..., SEE BELOW)
C
C     XEND        FINAL X-VALUE (XEND > X)
C
C     RTOL,ATOL   RELATIVE AND ABSOLUTE ERROR TOLERANCES. THEY
C                 CAN BE BOTH SCALARS OR ELSE BOTH VECTORS OF LENGTH N.
C
C     ITOL        SWITCH FOR RTOL AND ATOL:
C                   ITOL=0: BOTH RTOL AND ATOL ARE SCALARS.
C                     THE CODE KEEPS, ROUGHLY, THE LOCAL ERROR OF
C                     Y(I) BELOW RTOL*ABS(Y(I))+ATOL
C                   ITOL=1: BOTH RTOL AND ATOL ARE VECTORS.
C                     THE CODE KEEPS THE LOCAL ERROR OF Y(I) BELOW
C                     RTOL(I)*ABS(Y(I))+ATOL(I).
C
C     SOLOUT      NAME (EXTERNAL) OF SUBROUTINE PROVIDING THE
C                 NUMERICAL SOLUTION DURING INTEGRATION.
C                 IF IOUT.GE.1, IT IS CALLED AFTER EVERY SUCCESSFUL STEP.
C                 SUPPLY A DUMMY SUBROUTINE IF IOUT=0.
C                 IT MUST HAVE THE FORM
C                    SUBROUTINE SOLOUT (NR,XOLD,X,Y,N,RPAR,IPAR,IRTRN)
C                    DOUBLE PRECISION X,XOLD,Y(N)
C                    ....
C                 SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH
C                    GRID-POINT "X" (THEREBY THE INITIAL VALUE IS
C                    THE FIRST GRID-POINT).
C                 "XOLD" IS THE PRECEEDING GRID-POINT.
C                 "IRTRN" SERVES TO INTERRUPT THE INTEGRATION. IF IRTRN
C                    IS SET <0, RETARD WILL RETURN TO THE CALLING PROGRAM.
C
C          -----  CONTINUOUS OUTPUT: -----
C                 DURING CALLS TO "SOLOUT" AS WELL AS TO "FCN", A
C                 CONTINUOUS SOLUTION IS AVAILABLE THROUGH HTHE FUNCTION
C                        >>>   YLAG(I,S,PHI,RPAR,IPAR)   <<<
C                 WHICH PROVIDES AN APPROXIMATION TO THE I-TH
C                 COMPONENT OF THE SOLUTION AT THE POINT S. THE VALUE S
C                 HAS TO LIE IN AN INTERVAL WHERE THE NUMERICAL SOLUTION
C                 IS ALREADY COMPUTED. IT DEPENDS ON THE SIZE OF LRCONT
C                 (SEE BELOW) HOW FAR BACK THE SOLUTION IS AVAILABLE.
C
C     IOUT        SWITCH FOR CALLING THE SUBROUTINE SOLOUT:
C                    IOUT=0: SUBROUTINE IS NEVER CALLED
C                    IOUT=1: SUBROUTINE IS USED FOR OUTPUT.
C
C     WORK        ARRAY OF WORKING SPACE OF LENGTH "LWORK".
C                 WORK(1),...,WORK(20) SERVE AS PARAMETERS FOR THE CODE.
C                 FOR STANDARD USE, SET THEM TO ZERO BEFORE CALLING.
C                 "LWORK" MUST BE AT LEAST  8*N+21+NGRID
C                 WHERE NGRID=IWORK(6)
C
C     LWORK       DECLARED LENGHT OF ARRAY "WORK".
C
C     IWORK       INTEGER WORKING SPACE OF LENGTH "LIWORK".
C                 IWORK(1),...,IWORK(20) SERVE AS PARAMETERS FOR THE CODE.
C                 FOR STANDARD USE, SET THEM TO ZERO BEFORE CALLING.
C                 "LIWORK" MUST BE AT LEAST 20 .
C
C     LIWORK      DECLARED LENGHT OF ARRAY "IWORK".
C
C     LRCONT      DECLARED LENGTH OF COMMON BLOCK
C                  >>>  COMMON /CORER/RCONT(LRCONT)  <<<
C                 WHICH MUST BE DECLARED IN THE CALLING PROGRAM.
C                 "LRCONT" MUST BE SUFFICIENTLY LARGE. IF THE DENSE
C                 OUTPUT OF MXST BACK STEPS HAS TO BE STORED, IT MUST
C                 BE AT LEAST
C                          MXST * ( 5 * NRDENS + 2 )
C                 WHERE NRDENS=IWORK(5) (SEE BELOW).
C
C     LICONT      DECLARED LENGTH OF COMMON BLOCK
C                  >>>  COMMON /COREI/ICONT(LICONT)  <<<
C                 WHICH MUST BE DECLARED IN THE CALLING PROGRAM.
C                 "LICONT" MUST BE AT LEAST
C                              NRDENS + 1
C                 THESE COMMON BLOCKS ARE USED FOR STORING THE COEFFICIENTS
C                 OF THE CONTINUOUS SOLUTION AND MAKES THE CALLING LIST FOR
C                 THE FUNCTION "CONTD5" AS SIMPLE AS POSSIBLE.
C
C     RPAR, IPAR  REAL AND INTEGER PARAMETERS (OR PARAMETER ARRAYS) WHICH
C                 CAN BE USED FOR COMMUNICATION BETWEEN YOUR CALLING
C                 PROGRAM AND THE FCN, JAC, MAS, SOLOUT SUBROUTINES.
C
C-----------------------------------------------------------------------
C
C     SOPHISTICATED SETTING OF PARAMETERS
C     -----------------------------------
C              SEVERAL PARAMETERS (WORK(1),...,IWORK(1),...) ALLOW
C              TO ADAPT THE CODE TO THE PROBLEM AND TO THE NEEDS OF
C              THE USER. FOR ZERO INPUT, THE CODE CHOOSES DEFAULT VALUES.
C
C    WORK(1)   UROUND, THE ROUNDING UNIT, DEFAULT 2.3D-16.
C
C    WORK(2)   THE SAFETY FACTOR IN STEP SIZE PREDICTION,
C              DEFAULT 0.9D0.
C
C    WORK(3), WORK(4)   PARAMETERS FOR STEP SIZE SELECTION
C              THE NEW STEP SIZE IS CHOSEN SUBJECT TO THE RESTRICTION
C                 WORK(3) <= HNEW/HOLD <= WORK(4)
C              DEFAULT VALUES: WORK(3)=0.2D0, WORK(4)=10.D0
C
C    WORK(5)   IS THE "BETA" FOR STABILIZED STEP SIZE CONTROL (SEE
C              SECTION IV.2). LARGER VALUES OF BETA (<=0.1) MAKE THE
C              STEP SIZE CONTROL MORE STABLE. NEGATIVE WORK(5) PROVOKE
C              BETA=0. DEFAULT (FOR WORK(5)=0.D0) IS WORK(5)=0.04D0.
C
C    WORK(6)   MAXIMAL STEP SIZE, DEFAULT XEND-X.
C
C    WORK(7)   INITIAL STEP SIZE, FOR WORK(7)=0.D0 AN INITIAL GUESS
C              IS COMPUTED WITH HELP OF THE FUNCTION HINIT
C
C    WORK(21),...,WORK(20+NGRID)  PRESCRIBED POINTS, WHICH THE
C              INTEGRATION METHOD HAS TO TAKE AS GRID-POINTS
C              X < WORK(21) < WORK(22) < ... < WORK(20+NGRID) <= XEND
C
C    IWORK(1)  THIS IS THE MAXIMAL NUMBER OF ALLOWED STEPS.
C              THE DEFAULT VALUE (FOR IWORK(1)=0) IS 100000.
C
C    IWORK(2)  SWITCH FOR THE CHOICE OF THE COEFFICIENTS
C              IF IWORK(2).EQ.1  METHOD OF DORMAND AND PRINCE
C              (TABLE 5.2 OF SECTION II.5).
C              AT THE MOMENT THIS IS THE ONLY POSSIBLE CHOICE.
C              THE DEFAULT VALUE (FOR IWORK(2)=0) IS IWORK(2)=1.
C
C    IWORK(3)  SWITCH FOR PRINTING ERROR MESSAGES
C              IF IWORK(3).LT.0 NO MESSAGES ARE BEING PRINTED
C              IF IWORK(3).GT.0 MESSAGES ARE PRINTED WITH
C                 WRITE (IWORK(3),*) ...
C              DEFAULT VALUE (FOR IWORK(3)=0) IS IWORK(3)=6
C
C    IWORK(4)  TEST FOR STIFFNESS IS ACTIVATED AFTER STEP NUMBER
C              J*IWORK(4) (J INTEGER), PROVIDED IWORK(4).GT.0.
C              FOR NEGATIVE IWORK(4) THE STIFFNESS TEST IS
C              NEVER ACTIVATED; DEFAULT VALUE IS IWORK(4)=1000
C
C    IWORK(5)  = NRDENS = NUMBER OF COMPONENTS, FOR WHICH DENSE OUTPUT
C              IS REQUIRED (EITHER BY "SOLOUT" OR BY "FCN");
C              DEFAULT VALUE (FOR IWORK(5)=0) IS IWORK(5)=N;
C              FOR   0 < NRDENS < N   THE COMPONENTS (FOR WHICH DENSE
C              OUTPUT IS REQUIRED) HAVE TO BE SPECIFIED IN
C              ICONT(2),...,ICONT(NRDENS+1);
C              FOR  NRDENS=N  THIS IS DONE BY THE CODE.
C
C    IWORK(6)  = NGRID = NUMBER OF PRESCRIBED POINTS IN THE
C              INTEGRATION INTERVAL WHICH HAVE TO BE GRID-POINTS
C              IN THE INTEGRATION. USUALLY, AT THESE POINTS THE
C              SOLUTION OR ONE OF ITS DERIVATIVE HAS A DISCONTINUITY.
C              DEFINE THESE POINTS IN WORK(21),...,WORK(20+NGRID)
C              DEFAULT VALUE:  IWORK(6)=0
C
C----------------------------------------------------------------------
C
C     OUTPUT PARAMETERS
C     -----------------
C     X           X-VALUE FOR WHICH THE SOLUTION HAS BEEN COMPUTED
C                 (AFTER SUCCESSFUL RETURN X=XEND).
C
C     Y(N)        NUMERICAL SOLUTION AT X
C
C     H           PREDICTED STEP SIZE OF THE LAST ACCEPTED STEP
C
C     IDID        REPORTS ON SUCCESSFULNESS UPON RETURN:
C                   IDID= 1  COMPUTATION SUCCESSFUL,
C                   IDID= 2  COMPUT. SUCCESSFUL (INTERRUPTED BY SOLOUT)
C                   IDID=-1  INPUT IS NOT CONSISTENT,
C                   IDID=-2  LARGER NMAX IS NEEDED,
C                   IDID=-3  STEP SIZE BECOMES TOO SMALL.
C                   IDID=-4  PROBLEM IS PROBABLY STIFF (INTERRUPTED).
C                   IDID=-5  COMPUT. INTERRUPTED BY YLAG
C
C   IWORK(17)  NFCN    NUMBER OF FUNCTION EVALUATIONS
C   IWORK(18)  NSTEP   NUMBER OF COMPUTED STEPS
C   IWORK(19)  NACCPT  NUMBER OF ACCEPTED STEPS
C   IWORK(20)  NREJCT  NUMBER OF REJECTED STEPS (DUE TO ERROR TEST),
C                      (STEP REJECTIONS IN THE FIRST STEP ARE NOT COUNTED)
C-----------------------------------------------------------------------
C *** *** *** *** *** *** *** *** *** *** *** *** ***
C          DECLARATIONS
C *** *** *** *** *** *** *** *** *** *** *** *** ***
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION Y(N),ATOL(*),RTOL(*),WORK(LWORK),IWORK(LIWORK)
      DIMENSION RPAR(*),IPAR(*)
      LOGICAL ARRET
      EXTERNAL FCN,SOLOUT
      COMMON /CORER/RCONT(1)
      COMMON /COREI/NRDS,ICONT(1)
      COMMON /POSITS/X0BEG,UROUND,HMAX,LAST,IPOS,IRTRN,IDIF,MXST,IPRINT
C *** *** *** *** *** *** ***
C        SETTING THE PARAMETERS
C *** *** *** *** *** *** ***
      NFCN=0
      NSTEP=0
      NACCPT=0
      NREJCT=0
      ARRET=.FALSE.
C -------- IPRINT FOR MONITORING THE PRINTING
      IF(IWORK(3).EQ.0)THEN
         IPRINT=6
      ELSE
         IPRINT=IWORK(3)
      END IF
C -------- NMAX , THE MAXIMAL NUMBER OF STEPS -----
      IF(IWORK(1).EQ.0)THEN
         NMAX=100000
      ELSE
         NMAX=IWORK(1)
         IF(NMAX.LE.0)THEN
            IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &          ' WRONG INPUT IWORK(1)=',IWORK(1)
            ARRET=.TRUE.
         END IF
      END IF
C -------- METH   COEFFICIENTS OF THE METHOD
      IF(IWORK(2).EQ.0)THEN
         METH=1
      ELSE
         METH=IWORK(2)
         IF(METH.LE.0.OR.METH.GE.2)THEN
            IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &          ' CURIOUS INPUT IWORK(2)=',IWORK(2)
            ARRET=.TRUE.
         END IF
      END IF
C -------- NSTIFF   PARAMETER FOR STIFFNESS DETECTION
      NSTIFF=IWORK(4)
      IF (NSTIFF.EQ.0) NSTIFF=1000
      IF (NSTIFF.LT.0) NSTIFF=NMAX+10
C -------- NRDENS   NUMBER OF DENSE OUTPUT COMPONENTS
      NRDENS=IWORK(5)
      IF(NRDENS.LT.0.OR.NRDENS.GT.N)THEN
         IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &           ' CURIOUS INPUT IWORK(5)=',IWORK(5)
         ARRET=.TRUE.
      ELSE
         IF (NRDENS.EQ.0) NRDENS=N
C --------- CONTROL OF LENGTH OF COMMON BLOCK "CORER" -------
         IF(LRCONT.LT.(5*NRDENS+2))THEN
            IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &    ' INSUFFICIENT STORAGE FOR RCONT, MIN. LRCONT=',5*NRDENS+2
            ARRET=.TRUE.
         END IF
C --------- CONTROL OF LENGTH OF COMMON BLOCK "COREI" -------
         IF(LICONT.LT.(NRDENS+1))THEN
            IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &    ' INSUFFICIENT STORAGE FOR ICONT, MIN. LICONT=',NRDENS+1
            ARRET=.TRUE.
         ELSE
            NRDS=NRDENS
            IF (NRDENS.EQ.N) THEN
                DO 16 I=1,NRDENS
  16            ICONT(I)=I
            END IF
         END IF
      END IF
C -------- NGRID   NUMBER OF PRESCRIBED GRID-POINTS
      NGRID=IWORK(6)
      IF (NGRID.LT.0) NGRID=0
C -------- UROUND   SMALLEST NUMBER SATISFYING 1.D0+UROUND>1.D0
      IF(WORK(1).EQ.0.D0)THEN
         UROUND=2.3D-16
      ELSE
         UROUND=WORK(1)
         IF(UROUND.LE.1.D-35.OR.UROUND.GE.1.D0)THEN
            IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &        ' WHICH MACHINE DO YOU HAVE? YOUR UROUND WAS:',WORK(1)
            ARRET=.TRUE.
         END IF
      END IF
C -------  SAFETY FACTOR -------------
      IF(WORK(2).EQ.0.D0)THEN
         SAFE=0.9D0
      ELSE
         SAFE=WORK(2)
         IF(SAFE.GE.1.D0.OR.SAFE.LE.1.D-4)THEN
            IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &          ' CURIOUS INPUT FOR SAFETY FACTOR WORK(2)=',WORK(2)
            ARRET=.TRUE.
         END IF
      END IF
C -------  FAC1,FAC2     PARAMETERS FOR STEP SIZE SELECTION
      IF(WORK(3).EQ.0.D0)THEN
         FAC1=0.2D0
      ELSE
         FAC1=WORK(3)
      END IF
      IF(WORK(4).EQ.0.D0)THEN
         FAC2=10.D0
      ELSE
         FAC2=WORK(4)
      END IF
C --------- BETA FOR STEP CONTROL STABILIZATION -----------
      IF(WORK(5).EQ.0.D0)THEN
         BETA=0.04D0
      ELSE
         IF(WORK(5).LT.0.D0)THEN
            BETA=0.D0
         ELSE
            BETA=WORK(5)
            IF(BETA.GT.0.2D0)THEN
               IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &          ' CURIOUS INPUT FOR BETA: WORK(5)=',WORK(5)
            ARRET=.TRUE.
         END IF
         END IF
      END IF
C -------- MAXIMAL STEP SIZE
      IF(WORK(6).EQ.0.D0)THEN
         HMAX=XEND-X
      ELSE
         HMAX=WORK(6)
      END IF
C -------- INITIAL STEP SIZE
      H=WORK(7)
C -------- GRID WITH DISCONTINUITIES
      XURO=100*UROUND*ABS(XEND)
      IF (WORK(20+NGRID)-XEND.GE.XURO) THEN
         IF(IPRINT.GT.0) WRITE(IPRINT,*)
     &          ' WORK(20+NGRID) HAS TO BE <= XEND'
         ARRET=.TRUE.
      END IF
      IF (ABS(WORK(20+NGRID)-XEND).GE.XURO) NGRID=NGRID+1
      WORK(20+NGRID)=XEND
C ------- PREPARE THE ENTRY-POINTS FOR THE ARRAYS IN WORK -----
      IEGR=21
      IEY1=IEGR+NGRID
      IEK1=IEY1+N
      IEK2=IEK1+N
      IEK3=IEK2+N
      IEK4=IEK3+N
      IEK5=IEK4+N
      IEK6=IEK5+N
      IEYS=IEK6+N
C ------ TOTAL STORAGE REQUIREMENT -----------
      ISTORE=IEYS+N-1
      IF(ISTORE.GT.LWORK)THEN
        IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &   ' INSUFFICIENT STORAGE FOR WORK, MIN. LWORK=',ISTORE
        ARRET=.TRUE.
      END IF
      ISTORE=20
      IF(ISTORE.GT.LIWORK)THEN
        IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &   ' INSUFFICIENT STORAGE FOR IWORK, MIN. LIWORK=',ISTORE
        ARRET=.TRUE.
      END IF
C ------ WHEN A FAIL HAS OCCURED, WE RETURN WITH IDID=-1
      IF (ARRET) THEN
         IDID=-1
         RETURN
      END IF
C -------- CALL TO CORE INTEGRATOR ------------
      IDIF=5*NRDENS+2
      MXST=LRCONT/IDIF
      CALL RETCOR(N,FCN,X,Y,XEND,H,RTOL,ATOL,ITOL,SOLOUT,IOUT,
     &   IDID,NMAX,METH,NSTIFF,SAFE,BETA,FAC1,FAC2,NGRID,
     &   WORK(IEY1),WORK(IEK1),WORK(IEK2),WORK(IEK3),WORK(IEK4),
     &   WORK(IEK5),WORK(IEK6),WORK(IEYS),WORK(IEGR),
     &   RPAR,IPAR,NFCN,NSTEP,NACCPT,NREJCT)
      WORK(7)=H
      IWORK(17)=NFCN
      IWORK(18)=NSTEP
      IWORK(19)=NACCPT
      IWORK(20)=NREJCT
C ----------- RETURN -----------
      RETURN
      END
C
C
C
C  ----- ... AND HERE IS THE CORE INTEGRATOR  ----------
C
      SUBROUTINE RETCOR(N,FCN,X,Y,XEND,H,RTOL,ATOL,ITOL,SOLOUT,IOUT,
     &   IDID,NMAX,METH,NSTIFF,SAFE,BETA,FAC1,FAC2,NGRID,Y1,K1,K2,K3,
     &   K4,K5,K6,YSTI,GRID,RPAR,IPAR,NFCN,NSTEP,NACCPT,NREJCT)
C ----------------------------------------------------------
C     CORE INTEGRATOR FOR RETARD
C     PARAMETERS SAME AS IN RETARD WITH WORKSPACE ADDED
C ----------------------------------------------------------
C         DECLARATIONS
C ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION Y(N),Y1(N),K1(N),K2(N),K3(N),K4(N),K5(N),K6(N)
      DIMENSION GRID(NGRID),YSTI(N)
      DIMENSION ATOL(*),RTOL(*),RPAR(*),IPAR(*)
      LOGICAL REJECT,LAST
      EXTERNAL FCN
      COMMON /CORER/CONT(1)
      COMMON /COREI/NRD,ICOMP(1)
      COMMON /POSITS/X0BEG,UROUND,HMAX,IACT,IPOS,IRTRN,IDIF,MXST,IPRINT
C *** *** *** *** *** *** ***
C  INITIALISATIONS
C *** *** *** *** *** *** ***
      IF (METH.EQ.1) CALL CDOPRI(C2,C3,C4,C5,E1,E3,E4,E5,E6,E7,
     &                    A21,A31,A32,A41,A42,A43,A51,A52,A53,A54,
     &                    A61,A62,A63,A64,A65,A71,A73,A74,A75,A76,
     &                    D1,D3,D4,D5,D6,D7)
      FACOLD=1.D-4
      EXPO1=0.2D0-BETA*0.75D0
      FACC1=1.D0/FAC1
      FACC2=1.D0/FAC2
      POSNEG=SIGN(1.D0,XEND-X)
C --- INITIAL PREPARATIONS
      IACT=1
      IPOS=1
      X0BEG=X
      XEND=GRID(1)
      IGRID=1
      UROUND=10*UROUND
      DO 3 I=0,MXST-1
  3      CONT(1+IDIF*I)=X
      ATOLI=ATOL(1)
      RTOLI=RTOL(1)
      LAST=.FALSE.
      HLAMB=0.D0
      IASTI=0
      HMAX=ABS(HMAX)
      IRTRN=2
      CALL FCN(N,X,Y,K1,RPAR,IPAR)
      IRTRN=1
      IORD=5
      IF (H.EQ.0.D0) H=HINIT(N,FCN,X,Y,XEND,POSNEG,K1,K2,K3,IORD,
     &                       HMAX,ATOL,RTOL,ITOL,RPAR,IPAR)
      NFCN=NFCN+2
      REJECT=.FALSE.
      XOLD=X
      IF (IOUT.NE.0) THEN
          CALL SOLOUT(NACCPT+1,XOLD,X,Y,N,RPAR,IPAR,IRTRN)
          IF (IRTRN.LT.0) GOTO 79
      END IF
C --- BASIC INTEGRATION STEP
   1  CONTINUE
      IF (NSTEP.GT.NMAX) GOTO 78
      IF (ABS(H).LE.ABS(X)*UROUND)GOTO 77
      IF ((X+1.01D0*H-XEND)*POSNEG.GT.0.D0) THEN
         H=XEND-X
         LAST=.TRUE.
      ELSE
         IF ((X+1.8D0*H-XEND)*POSNEG.GT.0.D0) H=(XEND-X)*0.55D0
      END IF
      NSTEP=NSTEP+1
C --- THE FIRST 6 STAGES
      DO 22 I=1,N
  22  Y1(I)=Y(I)+H*A21*K1(I)
      CALL FCN(N,X+C2*H,Y1,K2,RPAR,IPAR)
      DO 23 I=1,N
  23  Y1(I)=Y(I)+H*(A31*K1(I)+A32*K2(I))
      CALL FCN(N,X+C3*H,Y1,K3,RPAR,IPAR)
      DO 24 I=1,N
  24  Y1(I)=Y(I)+H*(A41*K1(I)+A42*K2(I)+A43*K3(I))
      CALL FCN(N,X+C4*H,Y1,K4,RPAR,IPAR)
      DO 25 I=1,N
  25  Y1(I)=Y(I)+H*(A51*K1(I)+A52*K2(I)+A53*K3(I)+A54*K4(I))
      CALL FCN(N,X+C5*H,Y1,K5,RPAR,IPAR)
      DO 26 I=1,N
  26  YSTI(I)=Y(I)+H*(A61*K1(I)+A62*K2(I)+A63*K3(I)+A64*K4(I)+A65*K5(I))
      XPH=X+H
      CALL FCN(N,XPH,YSTI,K6,RPAR,IPAR)
      DO 27 I=1,N
  27  Y1(I)=Y(I)+H*(A71*K1(I)+A73*K3(I)+A74*K4(I)+A75*K5(I)+A76*K6(I))
      IRTRN=1
      CALL FCN(N,XPH,Y1,K2,RPAR,IPAR)
C ------  PREPARE DENSE OUTPUT
            NRDL=4*NRD+IACT
            DO 40 J=1,NRD
            I=ICOMP(J)
            CONT(NRDL+J)=H*(D1*K1(I)+D3*K3(I)+D4*K4(I)+D5*K5(I)
     &                   +D6*K6(I)+D7*K2(I))
  40        CONTINUE
C -------
      DO 28 I=1,N
  28  K4(I)=(E1*K1(I)+E3*K3(I)+E4*K4(I)+E5*K5(I)+E6*K6(I)+E7*K2(I))*H
      NFCN=NFCN+6
C ------ ERROR ESTIMATION
      ERR=0.D0
      IF (ITOL.EQ.0) THEN
        DO 41 I=1,N
        SK=ATOLI+RTOLI*MAX(ABS(Y(I)),ABS(Y1(I)))
  41    ERR=ERR+(K4(I)/SK)**2
      ELSE
        DO 42 I=1,N
        SK=ATOL(I)+RTOL(I)*MAX(ABS(Y(I)),ABS(Y1(I)))
  42    ERR=ERR+(K4(I)/SK)**2
      END IF
      ERR=SQRT(ERR/N)
C --- COMPUTATION OF HNEW
      FAC11=ERR**EXPO1
C --- LUND-STABILIZATION
      FAC=FAC11/FACOLD**BETA
C --- WE REQUIRE  FAC1 <= HNEW/H <= FAC2
      FAC=MAX(FACC2,MIN(FACC1,FAC/SAFE))
      HNEW=H/FAC
      IF(ERR.LE.1.D0)THEN
C --- STEP IS ACCEPTED
         FACOLD=MAX(ERR,1.0D-4)
         NACCPT=NACCPT+1
C ------- STIFFNESS DETECTION
         IF (MOD(NACCPT,NSTIFF).EQ.0.OR.IASTI.GT.0) THEN
            STNUM=0.D0
            STDEN=0.D0
            DO 64 I=1,N
               STNUM=STNUM+(K2(I)-K6(I))**2
               STDEN=STDEN+(Y1(I)-YSTI(I))**2
 64         CONTINUE
            IF (STDEN.GT.0.D0) HLAMB=H*SQRT(STNUM/STDEN)
            IF (HLAMB.GT.3.25D0) THEN
               NONSTI=0
               IASTI=IASTI+1
               IF (IASTI.EQ.15) THEN
                  IF (IPRINT.GT.0) WRITE (IPRINT,*)
     &               ' THE PROBLEM SEEMS TO BECOME STIFF AT X = ',X
                  IF (IPRINT.LE.0) GOTO 76
               END IF
            ELSE
               NONSTI=NONSTI+1
               IF (NONSTI.EQ.6) IASTI=0
            END IF
         END IF
C -------   COMPUTE DENSE OUTPUT
            DO 43 J=1,NRD
            I=ICOMP(J)
            YDIFF=Y1(I)-Y(I)
            BSPL=H*K1(I)-YDIFF
            CONT(IACT+J)=Y(I)
            CONT(IACT+NRD+J)=YDIFF
            CONT(IACT+2*NRD+J)=BSPL
            CONT(IACT+3*NRD+J)=-H*K2(I)+YDIFF-BSPL
  43        CONTINUE
            CONT(IACT)=X
            IACT=IACT+IDIF
            CONT(IACT-1)=H
            IF (IACT+IDIF-1.GT.MXST*IDIF) IACT=1
C ------
         DO 44 I=1,N
         K1(I)=K2(I)
  44     Y(I)=Y1(I)
         XOLD=X
         X=XPH
         IF (IRTRN.EQ.3) THEN
            IRTRN=4
            CALL FCN(N,X,Y,K1,RPAR,IPAR)
            NFCN=NFCN+1
            IRTRN=1
         END IF
         IF (IOUT.NE.0) THEN
            CALL SOLOUT(NACCPT+1,XOLD,X,Y,N,RPAR,IPAR,IRTRN)
            IF (IRTRN.LT.0) GOTO 79
         END IF
C ------- NORMAL EXIT
         IF (LAST) THEN
            IF (IGRID.EQ.NGRID) THEN
               H=HNEW
               IDID=1
               RETURN
            ELSE
               IGRID=IGRID+1
               LAST=.FALSE.
               XEND=GRID(IGRID)
               HNEW=0.9D0*HNEW
            END IF
         END IF
         IF(ABS(HNEW).GT.HMAX)HNEW=POSNEG*HMAX
         IF(REJECT)HNEW=POSNEG*MIN(ABS(HNEW),ABS(H))
         REJECT=.FALSE.
      ELSE
C --- STEP IS REJECTED
         IF (IRTRN.LT.0) GOTO 79
         HNEW=H/MIN(FACC1,FAC11/SAFE)
         REJECT=.TRUE.
         IF(NACCPT.GE.1)NREJCT=NREJCT+1
         LAST=.FALSE.
      END IF
      H=HNEW
      IF (IRTRN.LT.0) GOTO 75
      GOTO 1
C --- FAIL EXIT
  75  CONTINUE
      IDID=-5
      RETURN
  76  CONTINUE
      IDID=-4
      RETURN
  77  CONTINUE
      IF (IPRINT.GT.0) WRITE(IPRINT,979)X
      IF (IPRINT.GT.0) WRITE(IPRINT,*)' STEP SIZE T0O SMALL, H=',H
      IDID=-3
      RETURN
  78  CONTINUE
      IF (IPRINT.GT.0) WRITE(IPRINT,979)X
      IF (IPRINT.GT.0) WRITE(IPRINT,*)
     &     ' MORE THAN NMAX =',NMAX,'STEPS ARE NEEDED'
      IDID=-2
      RETURN
  79  CONTINUE
      IF (IPRINT.GT.0) WRITE(IPRINT,979)X
 979  FORMAT(' EXIT OF RETARD AT X=',E18.4)
      IDID=2
      RETURN
      END
C
C
      FUNCTION YLAG(II,X,PHI,RPAR,IPAR)
C ----------------------------------------------------------
C     THIS FUNCTION CAN BE USED FOR CONINUOUS OUTPUT IN CONECTION
C     WITH THE OUTPUT-SUBROUTINE FOR RETARD. IT PROVIDES AN
C     APPROXIMATION TO THE I-TH COMPONENT OF THE SOLUTION AT X.
C ----------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION RPAR(*),IPAR(*)
      COMMON /CORER/CON(1)
      COMMON /COREI/ND,ICOMP(1)
      COMMON /POSITS/X0,UR4,HMAX,IACT,IPOS,IRTRN,IDIF,MXST,IPRINT
C ----- INITIAL PHASE
      COMPAR=UR4*MAX(ABS(X),ABS(X0))
         IF (X-X0.LE.COMPAR) THEN
            IF (IRTRN.LE.3) THEN
               YLAG=PHI(II,X,RPAR,IPAR)
               IF (IRTRN.EQ.2) HMAX=MIN(HMAX,X0-X)
               IF (X0-X.LE.COMPAR) IRTRN=3
               RETURN
            ELSE
               IF (X0-X.GT.COMPAR) THEN
                  YLAG=PHI(II,X,RPAR,IPAR)
                  RETURN
               END IF
            END IF
         END IF
C ----- COMPUTE PLACE OF II-TH COMPONENT
      I=0
      DO 5 J=1,ND
      IF (ICOMP(J).EQ.II) I=J
   5  CONTINUE
      IF (I.EQ.0) THEN
         IF (IPRINT.GT.0) WRITE (IPRINT,*)
     &           ' NO DENSE OUTPUT AVAILABLE FOR COMP.',II
         RETURN
      END IF
C ----- COMPUTE THE POSITION OF X
      IF (X-CON(IACT).LT.-COMPAR) THEN
         IF (IPRINT.GT.0) WRITE (IPRINT,*)
     &          ' MEMORY FULL, MXST = ',MXST
         IRTRN=-1
         RETURN
      END IF
      INEXT=IACT-IDIF
      IF (INEXT.LT.1) INEXT=(MXST-1)*IDIF+1
      XRIGHT=CON(INEXT)+CON(INEXT+IDIF-1)
      IF (X-XRIGHT.GT.UR4*MAX(ABS(X),ABS(XRIGHT))) THEN
         IF (IPRINT.GT.0) WRITE (IPRINT,*)
     &          ' DONT USE ADVANCED ARGUMENTS '
         IRTRN=-1
         RETURN
      END IF
   1  CONTINUE
      IF (X-CON(IPOS).LT.-COMPAR) THEN
         IPOS=IPOS-IDIF
         IF (IPOS.LT.1) IPOS=(MXST-1)*IDIF+1
         GOTO 1
      END IF
   2  CONTINUE
      INEXT=IPOS+IDIF
      IF (INEXT.GT.(MXST-1)*IDIF+1) INEXT=1
      IF (X.GT.CON(INEXT).AND.INEXT.NE.IACT) THEN
         IPOS=INEXT
         GOTO 2
      END IF
C ----- COMPUTE DESIRED APPROXIMATION
      THETA=(X-CON(IPOS))/CON(IPOS+IDIF-1)
      THETA1=1.D0-THETA
      I=I+IPOS
      YLAG=CON(I)+THETA*(CON(ND+I)+THETA1*(CON(2*ND+I)+THETA*
     &           (CON(3*ND+I)+THETA1*CON(4*ND+I))))
      RETURN
      END
C


*DECK SSICO
      SUBROUTINE SSICO (A, LDA, N, KPVT, RCOND, Z)
C***BEGIN PROLOGUE  SSICO
C***PURPOSE  Factor a symmetric matrix by elimination with symmetric
C            pivoting and estimate the condition number of the matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B1A
C***TYPE      SINGLE PRECISION (SSICO-S, DSICO-D, CHICO-C, CSICO-C)
C***KEYWORDS  CONDITION NUMBER, LINEAR ALGEBRA, LINPACK,
C             MATRIX FACTORIZATION, SYMMETRIC
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     SSICO factors a real symmetric matrix by elimination with
C     symmetric pivoting and estimates the condition of the matrix.
C
C     If  RCOND  is not needed, SSIFA is slightly faster.
C     To solve  A*X = B , follow SSICO by SSISL.
C     To compute  INVERSE(A)*C , follow SSICO by SSISL.
C     To compute  INVERSE(A) , follow SSICO by SSIDI.
C     To compute  DETERMINANT(A) , follow SSICO by SSIDI.
C     To compute  INERTIA(A), follow SSICO by SSIDI.
C
C     On Entry
C
C        A       REAL(LDA, N)
C                the symmetric matrix to be factored.
C                Only the diagonal and upper triangle are used.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C     Output
C
C        A       a block diagonal matrix and the multipliers which
C                were used to obtain it.
C                The factorization can be written  A = U*D*TRANS(U)
C                where  U  is a product of permutation and unit
C                upper triangular matrices , TRANS(U) is the
C                transpose of  U , and  D  is block diagonal
C                with 1 by 1 and 2 by 2 blocks.
C
C        KPVT    INTEGER(N)
C                an integer vector of pivot indices.
C
C        RCOND   REAL
C                an estimate of the reciprocal condition of  A .
C                For the system  A*X = B , relative perturbations
C                in  A  and  B  of size  EPSILON  may cause
C                relative perturbations in  X  of size  EPSILON/RCOND .
C                If  RCOND  is so small that the logical expression
C                           1.0 + RCOND .EQ. 1.0
C                is true, then  A  may be singular to working
C                precision.  In particular,  RCOND  is zero  if
C                exact singularity is detected or the estimate
C                underflows.
C
C        Z       REAL(N)
C                a work vector whose contents are usually unimportant.
C                If  A  is close to a singular matrix, then  Z  is
C                an approximate null vector in the sense that
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  SASUM, SAXPY, SDOT, SSCAL, SSIFA
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891107  Modified routine equivalence list.  (WRB)
C   891107  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SSICO
      INTEGER LDA,N,KPVT(*)
      REAL A(LDA,*),Z(*)
      REAL RCOND
C
      REAL AK,AKM1,BK,BKM1,SDOT,DENOM,EK,T
      REAL ANORM,S,SASUM,YNORM
      INTEGER I,INFO,J,JM1,K,KP,KPS,KS
C
C     FIND NORM OF A USING ONLY UPPER HALF
C
C***FIRST EXECUTABLE STATEMENT  SSICO
      DO 30 J = 1, N
         Z(J) = SASUM(J,A(1,J),1)
         JM1 = J - 1
         IF (JM1 .LT. 1) GO TO 20
         DO 10 I = 1, JM1
            Z(I) = Z(I) + ABS(A(I,J))
   10    CONTINUE
   20    CONTINUE
   30 CONTINUE
      ANORM = 0.0E0
      DO 40 J = 1, N
         ANORM = MAX(ANORM,Z(J))
   40 CONTINUE
C
C     FACTOR
C
      CALL SSIFA(A,LDA,N,KPVT,INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  A*Y = E .
C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C     GROWTH IN THE ELEMENTS OF W  WHERE  U*D*W = E .
C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
C
C     SOLVE U*D*W = E
C
      EK = 1.0E0
      DO 50 J = 1, N
         Z(J) = 0.0E0
   50 CONTINUE
      K = N
   60 IF (K .EQ. 0) GO TO 120
         KS = 1
         IF (KPVT(K) .LT. 0) KS = 2
         KP = ABS(KPVT(K))
         KPS = K + 1 - KS
         IF (KP .EQ. KPS) GO TO 70
            T = Z(KPS)
            Z(KPS) = Z(KP)
            Z(KP) = T
   70    CONTINUE
         IF (Z(K) .NE. 0.0E0) EK = SIGN(EK,Z(K))
         Z(K) = Z(K) + EK
         CALL SAXPY(K-KS,Z(K),A(1,K),1,Z(1),1)
         IF (KS .EQ. 1) GO TO 80
            IF (Z(K-1) .NE. 0.0E0) EK = SIGN(EK,Z(K-1))
            Z(K-1) = Z(K-1) + EK
            CALL SAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1)
   80    CONTINUE
         IF (KS .EQ. 2) GO TO 100
            IF (ABS(Z(K)) .LE. ABS(A(K,K))) GO TO 90
               S = ABS(A(K,K))/ABS(Z(K))
               CALL SSCAL(N,S,Z,1)
               EK = S*EK
   90       CONTINUE
            IF (A(K,K) .NE. 0.0E0) Z(K) = Z(K)/A(K,K)
            IF (A(K,K) .EQ. 0.0E0) Z(K) = 1.0E0
         GO TO 110
  100    CONTINUE
            AK = A(K,K)/A(K-1,K)
            AKM1 = A(K-1,K-1)/A(K-1,K)
            BK = Z(K)/A(K-1,K)
            BKM1 = Z(K-1)/A(K-1,K)
            DENOM = AK*AKM1 - 1.0E0
            Z(K) = (AKM1*BK - BKM1)/DENOM
            Z(K-1) = (AK*BKM1 - BK)/DENOM
  110    CONTINUE
         K = K - KS
      GO TO 60
  120 CONTINUE
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
C
C     SOLVE TRANS(U)*Y = W
C
      K = 1
  130 IF (K .GT. N) GO TO 160
         KS = 1
         IF (KPVT(K) .LT. 0) KS = 2
         IF (K .EQ. 1) GO TO 150
            Z(K) = Z(K) + SDOT(K-1,A(1,K),1,Z(1),1)
            IF (KS .EQ. 2)
     1         Z(K+1) = Z(K+1) + SDOT(K-1,A(1,K+1),1,Z(1),1)
            KP = ABS(KPVT(K))
            IF (KP .EQ. K) GO TO 140
               T = Z(K)
               Z(K) = Z(KP)
               Z(KP) = T
  140       CONTINUE
  150    CONTINUE
         K = K + KS
      GO TO 130
  160 CONTINUE
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
C
      YNORM = 1.0E0
C
C     SOLVE U*D*V = Y
C
      K = N
  170 IF (K .EQ. 0) GO TO 230
         KS = 1
         IF (KPVT(K) .LT. 0) KS = 2
         IF (K .EQ. KS) GO TO 190
            KP = ABS(KPVT(K))
            KPS = K + 1 - KS
            IF (KP .EQ. KPS) GO TO 180
               T = Z(KPS)
               Z(KPS) = Z(KP)
               Z(KP) = T
  180       CONTINUE
            CALL SAXPY(K-KS,Z(K),A(1,K),1,Z(1),1)
            IF (KS .EQ. 2) CALL SAXPY(K-KS,Z(K-1),A(1,K-1),1,Z(1),1)
  190    CONTINUE
         IF (KS .EQ. 2) GO TO 210
            IF (ABS(Z(K)) .LE. ABS(A(K,K))) GO TO 200
               S = ABS(A(K,K))/ABS(Z(K))
               CALL SSCAL(N,S,Z,1)
               YNORM = S*YNORM
  200       CONTINUE
            IF (A(K,K) .NE. 0.0E0) Z(K) = Z(K)/A(K,K)
            IF (A(K,K) .EQ. 0.0E0) Z(K) = 1.0E0
         GO TO 220
  210    CONTINUE
            AK = A(K,K)/A(K-1,K)
            AKM1 = A(K-1,K-1)/A(K-1,K)
            BK = Z(K)/A(K-1,K)
            BKM1 = Z(K-1)/A(K-1,K)
            DENOM = AK*AKM1 - 1.0E0
            Z(K) = (AKM1*BK - BKM1)/DENOM
            Z(K-1) = (AK*BKM1 - BK)/DENOM
  220    CONTINUE
         K = K - KS
      GO TO 170
  230 CONTINUE
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
C     SOLVE TRANS(U)*Z = V
C
      K = 1
  240 IF (K .GT. N) GO TO 270
         KS = 1
         IF (KPVT(K) .LT. 0) KS = 2
         IF (K .EQ. 1) GO TO 260
            Z(K) = Z(K) + SDOT(K-1,A(1,K),1,Z(1),1)
            IF (KS .EQ. 2)
     1         Z(K+1) = Z(K+1) + SDOT(K-1,A(1,K+1),1,Z(1),1)
            KP = ABS(KPVT(K))
            IF (KP .EQ. K) GO TO 250
               T = Z(K)
               Z(K) = Z(KP)
               Z(KP) = T
  250       CONTINUE
  260    CONTINUE
         K = K + KS
      GO TO 240
  270 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0E0/SASUM(N,Z,1)
      CALL SSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
      IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
      RETURN
      END