      SUBROUTINE UD01CD( MP, NP, DP, NIN, P, LDP1, LDP2, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To read the elements of a sparse matrix polynomial
C                                                    dp-1           dp
C        P(s) = P(0) + P(1) * s + . . . + P(dp-1) * s    + P(dp) * s  .
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     MP      (input) INTEGER
C             The number of rows of the matrix polynomial P(s).
C             MP >= 1.
C
C     NP      (input) INTEGER
C             The number of columns of the matrix polynomial P(s).
C             NP >= 1.
C
C     DP      (input) INTEGER
C             The degree of the matrix polynomial P(s).  DP >= 0.
C
C     NIN     (input) INTEGER
C             The input channel from which the elements of P(s) are
C             read.  NIN >= 0.
C
C     P       (output) DOUBLE PRECISION array, dimension
C             (LDP1,LDP2,DP+1)
C             The leading MP-by-NP-by-(DP+1) part of this array contains
C             the coefficients of the matrix polynomial P(s).
C             Specifically, P(i,j,k) contains the coefficient of
C             s**(k-1) of the polynomial which is the (i,j)-th element
C             of P(s), where i = 1,2,...,MP, j = 1,2,...,NP and
C             k = 1,2,...,DP+1.
C             The not assigned elements are set to zero.
C
C     LDP1    INTEGER
C             The leading dimension of array P.  LDP1 >= MP.
C
C     LDP2    INTEGER
C             The second dimension of array P.  LDP2 >= NP.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1 : if a row index i is read with i < 1 or i > MP or
C                   a column index j is read with j < 1 or j > NP or
C                   a coefficient degree d is read with d < 0 or
C                   d > DP + 1. This is a warning.
C
C     METHOD
C
C     First, the elements P(i,j,k) with 1 <= i <= MP, 1 <= j <= NP and
C     1 <= k <= DP + 1 are set to zero. Next the nonzero (polynomial)
C     elements are read from the input file NIN. Each nonzero element is
C     given by the values i, j, d, P(i,j,k), k = 1, ..., d+1, where d is
C     the degree and P(i,j,k) is the coefficient of s**(k-1) in the
C     (i,j)-th element of P(s), i.e., let
C                                                              d
C         P   (s) = P   (0) + P   (1) * s + . . . + P   (d) * s
C          i,j       i,j       i,j                   i,j
C
C     be the nonzero (i,j)-th element of the matrix polynomial P(s).
C
C     Then P(i,j,k) corresponds to coefficient P   (k-1), k = 1,...,d+1.
C                                               i,j
C     For each nonzero element, the values i, j, and d are read as one
C     record of the file NIN, and the values P(i,j,k), k = 1,...,d+1,
C     are read as the following record.
C     The routine terminates after the last line has been read.
C
C     REFERENCES
C
C     None.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, June 1998.
C     Based on routine RDSPOM by A.J. Geurts, Eindhoven University of
C     Technology, Holland.
C
C     REVISIONS
C
C     -
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      INTEGER           DP, INFO, LDP1, LDP2, MP, NP, NIN
C     .. Array Arguments ..
      DOUBLE PRECISION  P(LDP1,LDP2,*)
C     .. Local Scalars ..
      INTEGER           D, I, J, K
C     .. External Subroutines ..
      EXTERNAL          DLASET, XERBLA
C
C     .. Executable Statements ..
C
      INFO = 0
C
C     Check the input scalar arguments.
C
      IF( MP.LT.1 ) THEN
         INFO = -1
      ELSE IF( NP.LT.1 ) THEN
         INFO = -2
      ELSE IF( DP.LT.0 ) THEN
         INFO = -3
      ELSE IF( NIN.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDP1.LT.MP ) THEN
         INFO = -6
      ELSE IF( LDP2.LT.NP ) THEN
         INFO = -7
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'UD01CD', -INFO )
         RETURN
      END IF
C
      DO 10 K = 1, DP+1
         CALL DLASET( 'Full', MP, NP, ZERO, ZERO, P(1,1,K), LDP1 )
   10 CONTINUE
C
C     Read (i, j, d, P(i,j,k), k=1,...,d+1) of the nonzero elements one
C     by one.
C
   20 READ( NIN, FMT = *, END = 30 ) I, J, D
      IF ( I.LT.1 .OR. I.GT.MP .OR. J.LT.1 .OR. J.GT.NP .OR.
     $     D.LT.0 .OR. D.GT.(DP+1) ) THEN
         INFO = 1
         READ ( NIN, FMT = * )
      ELSE
         READ ( NIN, FMT = * ) ( P(I,J,K), K = 1, D+1 )
      END IF
      GO TO 20
C
   30 CONTINUE
      RETURN
C *** Last line of UD01CD ***
      END


*> \brief \b ZTFTTP copies a triangular matrix from the rectangular full packed format (TF) to the standard packed format (TP).
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZTFTTP + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZTFTTP( TRANSR, UPLO, N, ARF, AP, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          TRANSR, UPLO
*       INTEGER            INFO, N
*       ..
*       .. Array Arguments ..
*       COMPLEX*16         AP( 0: * ), ARF( 0: * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZTFTTP copies a triangular matrix A from rectangular full packed
*> format (TF) to standard packed format (TP).
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] TRANSR
*> \verbatim
*>          TRANSR is CHARACTER*1
*>          = 'N':  ARF is in Normal format;
*>          = 'C':  ARF is in Conjugate-transpose format;
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          = 'U':  A is upper triangular;
*>          = 'L':  A is lower triangular.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] ARF
*> \verbatim
*>          ARF is COMPLEX*16 array, dimension ( N*(N+1)/2 ),
*>          On entry, the upper or lower triangular matrix A stored in
*>          RFP format. For a further discussion see Notes below.
*> \endverbatim
*>
*> \param[out] AP
*> \verbatim
*>          AP is COMPLEX*16 array, dimension ( N*(N+1)/2 ),
*>          On exit, the upper or lower triangular matrix A, packed
*>          columnwise in a linear array. The j-th column of A is stored
*>          in the array AP as follows:
*>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
*>          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup complex16OTHERcomputational
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  We first consider Standard Packed Format when N is even.
*>  We give an example where N = 6.
*>
*>      AP is Upper             AP is Lower
*>
*>   00 01 02 03 04 05       00
*>      11 12 13 14 15       10 11
*>         22 23 24 25       20 21 22
*>            33 34 35       30 31 32 33
*>               44 45       40 41 42 43 44
*>                  55       50 51 52 53 54 55
*>
*>
*>  Let TRANSR = 'N'. RFP holds AP as follows:
*>  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
*>  three columns of AP upper. The lower triangle A(4:6,0:2) consists of
*>  conjugate-transpose of the first three columns of AP upper.
*>  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
*>  three columns of AP lower. The upper triangle A(0:2,0:2) consists of
*>  conjugate-transpose of the last three columns of AP lower.
*>  To denote conjugate we place -- above the element. This covers the
*>  case N even and TRANSR = 'N'.
*>
*>         RFP A                   RFP A
*>
*>                                -- -- --
*>        03 04 05                33 43 53
*>                                   -- --
*>        13 14 15                00 44 54
*>                                      --
*>        23 24 25                10 11 55
*>
*>        33 34 35                20 21 22
*>        --
*>        00 44 45                30 31 32
*>        -- --
*>        01 11 55                40 41 42
*>        -- -- --
*>        02 12 22                50 51 52
*>
*>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
*>  transpose of RFP A above. One therefore gets:
*>
*>
*>           RFP A                   RFP A
*>
*>     -- -- -- --                -- -- -- -- -- --
*>     03 13 23 33 00 01 02    33 00 10 20 30 40 50
*>     -- -- -- -- --                -- -- -- -- --
*>     04 14 24 34 44 11 12    43 44 11 21 31 41 51
*>     -- -- -- -- -- --                -- -- -- --
*>     05 15 25 35 45 55 22    53 54 55 22 32 42 52
*>
*>
*>  We next consider Standard Packed Format when N is odd.
*>  We give an example where N = 5.
*>
*>     AP is Upper                 AP is Lower
*>
*>   00 01 02 03 04              00
*>      11 12 13 14              10 11
*>         22 23 24              20 21 22
*>            33 34              30 31 32 33
*>               44              40 41 42 43 44
*>
*>
*>  Let TRANSR = 'N'. RFP holds AP as follows:
*>  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
*>  three columns of AP upper. The lower triangle A(3:4,0:1) consists of
*>  conjugate-transpose of the first two   columns of AP upper.
*>  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
*>  three columns of AP lower. The upper triangle A(0:1,1:2) consists of
*>  conjugate-transpose of the last two   columns of AP lower.
*>  To denote conjugate we place -- above the element. This covers the
*>  case N odd  and TRANSR = 'N'.
*>
*>         RFP A                   RFP A
*>
*>                                   -- --
*>        02 03 04                00 33 43
*>                                      --
*>        12 13 14                10 11 44
*>
*>        22 23 24                20 21 22
*>        --
*>        00 33 34                30 31 32
*>        -- --
*>        01 11 44                40 41 42
*>
*>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
*>  transpose of RFP A above. One therefore gets:
*>
*>
*>           RFP A                   RFP A
*>
*>     -- -- --                   -- -- -- -- -- --
*>     02 12 22 00 01             00 10 20 30 40 50
*>     -- -- -- --                   -- -- -- -- --
*>     03 13 23 33 11             33 11 21 31 41 51
*>     -- -- -- -- --                   -- -- -- --
*>     04 14 24 34 44             43 44 22 32 42 52
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE ZTFTTP( TRANSR, UPLO, N, ARF, AP, INFO )
*
*  -- LAPACK computational routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      CHARACTER          TRANSR, UPLO
      INTEGER            INFO, N
*     ..
*     .. Array Arguments ..
      COMPLEX*16         AP( 0: * ), ARF( 0: * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
*     ..
*     .. Local Scalars ..
      LOGICAL            LOWER, NISODD, NORMALTRANSR
      INTEGER            N1, N2, K, NT
      INTEGER            I, J, IJ
      INTEGER            IJP, JP, LDA, JS
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DCONJG
*     ..
*     .. Intrinsic Functions ..
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NORMALTRANSR = LSAME( TRANSR, 'N' )
      LOWER = LSAME( UPLO, 'L' )
      IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZTFTTP', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
      IF( N.EQ.1 ) THEN
         IF( NORMALTRANSR ) THEN
            AP( 0 ) = ARF( 0 )
         ELSE
            AP( 0 ) = DCONJG( ARF( 0 ) )
         END IF
         RETURN
      END IF
*
*     Size of array ARF(0:NT-1)
*
      NT = N*( N+1 ) / 2
*
*     Set N1 and N2 depending on LOWER
*
      IF( LOWER ) THEN
         N2 = N / 2
         N1 = N - N2
      ELSE
         N1 = N / 2
         N2 = N - N1
      END IF
*
*     If N is odd, set NISODD = .TRUE.
*     If N is even, set K = N/2 and NISODD = .FALSE.
*
*     set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe)
*     where noe = 0 if n is even, noe = 1 if n is odd
*
      IF( MOD( N, 2 ).EQ.0 ) THEN
         K = N / 2
         NISODD = .FALSE.
         LDA = N + 1
      ELSE
         NISODD = .TRUE.
         LDA = N
      END IF
*
*     ARF^C has lda rows and n+1-noe cols
*
      IF( .NOT.NORMALTRANSR )
     $   LDA = ( N+1 ) / 2
*
*     start execution: there are eight cases
*
      IF( NISODD ) THEN
*
*        N is odd
*
         IF( NORMALTRANSR ) THEN
*
*           N is odd and TRANSR = 'N'
*
            IF( LOWER ) THEN
*
*             SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) )
*             T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0)
*             T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n
*
               IJP = 0
               JP = 0
               DO J = 0, N2
                  DO I = J, N - 1
                     IJ = I + JP
                     AP( IJP ) = ARF( IJ )
                     IJP = IJP + 1
                  END DO
                  JP = JP + LDA
               END DO
               DO I = 0, N2 - 1
                  DO J = 1 + I, N2
                     IJ = I + J*LDA
                     AP( IJP ) = DCONJG( ARF( IJ ) )
                     IJP = IJP + 1
                  END DO
               END DO
*
            ELSE
*
*             SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1)
*             T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0)
*             T1 -> a(n2), T2 -> a(n1), S -> a(0)
*
               IJP = 0
               DO J = 0, N1 - 1
                  IJ = N2 + J
                  DO I = 0, J
                     AP( IJP ) = DCONJG( ARF( IJ ) )
                     IJP = IJP + 1
                     IJ = IJ + LDA
                  END DO
               END DO
               JS = 0
               DO J = N1, N - 1
                  IJ = JS
                  DO IJ = JS, JS + J
                     AP( IJP ) = ARF( IJ )
                     IJP = IJP + 1
                  END DO
                  JS = JS + LDA
               END DO
*
            END IF
*
         ELSE
*
*           N is odd and TRANSR = 'C'
*
            IF( LOWER ) THEN
*
*              SRPA for LOWER, TRANSPOSE and N is odd
*              T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1)
*              T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1
*
               IJP = 0
               DO I = 0, N2
                  DO IJ = I*( LDA+1 ), N*LDA - 1, LDA
                     AP( IJP ) = DCONJG( ARF( IJ ) )
                     IJP = IJP + 1
                  END DO
               END DO
               JS = 1
               DO J = 0, N2 - 1
                  DO IJ = JS, JS + N2 - J - 1
                     AP( IJP ) = ARF( IJ )
                     IJP = IJP + 1
                  END DO
                  JS = JS + LDA + 1
               END DO
*
            ELSE
*
*              SRPA for UPPER, TRANSPOSE and N is odd
*              T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0)
*              T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2
*
               IJP = 0
               JS = N2*LDA
               DO J = 0, N1 - 1
                  DO IJ = JS, JS + J
                     AP( IJP ) = ARF( IJ )
                     IJP = IJP + 1
                  END DO
                  JS = JS + LDA
               END DO
               DO I = 0, N1
                  DO IJ = I, I + ( N1+I )*LDA, LDA
                     AP( IJP ) = DCONJG( ARF( IJ ) )
                     IJP = IJP + 1
                  END DO
               END DO
*
            END IF
*
         END IF
*
      ELSE
*
*        N is even
*
         IF( NORMALTRANSR ) THEN
*
*           N is even and TRANSR = 'N'
*
            IF( LOWER ) THEN
*
*              SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) )
*              T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0)
*              T1 -> a(1), T2 -> a(0), S -> a(k+1)
*
               IJP = 0
               JP = 0
               DO J = 0, K - 1
                  DO I = J, N - 1
                     IJ = 1 + I + JP
                     AP( IJP ) = ARF( IJ )
                     IJP = IJP + 1
                  END DO
                  JP = JP + LDA
               END DO
               DO I = 0, K - 1
                  DO J = I, K - 1
                     IJ = I + J*LDA
                     AP( IJP ) = DCONJG( ARF( IJ ) )
                     IJP = IJP + 1
                  END DO
               END DO
*
            ELSE
*
*              SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) )
*              T1 -> a(k+1,0) ,  T2 -> a(k,0),   S -> a(0,0)
*              T1 -> a(k+1), T2 -> a(k), S -> a(0)
*
               IJP = 0
               DO J = 0, K - 1
                  IJ = K + 1 + J
                  DO I = 0, J
                     AP( IJP ) = DCONJG( ARF( IJ ) )
                     IJP = IJP + 1
                     IJ = IJ + LDA
                  END DO
               END DO
               JS = 0
               DO J = K, N - 1
                  IJ = JS
                  DO IJ = JS, JS + J
                     AP( IJP ) = ARF( IJ )
                     IJP = IJP + 1
                  END DO
                  JS = JS + LDA
               END DO
*
            END IF
*
         ELSE
*
*           N is even and TRANSR = 'C'
*
            IF( LOWER ) THEN
*
*              SRPA for LOWER, TRANSPOSE and N is even (see paper)
*              T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1)
*              T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k
*
               IJP = 0
               DO I = 0, K - 1
                  DO IJ = I + ( I+1 )*LDA, ( N+1 )*LDA - 1, LDA
                     AP( IJP ) = DCONJG( ARF( IJ ) )
                     IJP = IJP + 1
                  END DO
               END DO
               JS = 0
               DO J = 0, K - 1
                  DO IJ = JS, JS + K - J - 1
                     AP( IJP ) = ARF( IJ )
                     IJP = IJP + 1
                  END DO
                  JS = JS + LDA + 1
               END DO
*
            ELSE
*
*              SRPA for UPPER, TRANSPOSE and N is even (see paper)
*              T1 -> B(0,k+1),     T2 -> B(0,k),   S -> B(0,0)
*              T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k
*
               IJP = 0
               JS = ( K+1 )*LDA
               DO J = 0, K - 1
                  DO IJ = JS, JS + J
                     AP( IJP ) = ARF( IJ )
                     IJP = IJP + 1
                  END DO
                  JS = JS + LDA
               END DO
               DO I = 0, K - 1
                  DO IJ = I, I + ( K+I )*LDA, LDA
                     AP( IJP ) = DCONJG( ARF( IJ ) )
                     IJP = IJP + 1
                  END DO
               END DO
*
            END IF
*
         END IF
*
      END IF
*
      RETURN
*
*     End of ZTFTTP
*
      END


subroutine process(x)
    real x(..)
    select rank(x)
        rank (0)
            x = 0
        rank (2)
            if (size(x,2)>=2) x(:,2) = 2
        rank default
            print *, 'i did not expect rank', rank(x), 'shape', shape(x)
            error stop 'process bad arg'
    end select
    return
end subroutine process

subroutine initialize (arg, size)
    real,contiguous :: arg(..)
    integer         :: size, i
    select rank (arg)
        rank (0)   ! special case the scalar case
            arg = 0.0
        rank (*)
            do i = 1, size
                arg(i) = 0.0
            end do
    end select
    return
end subroutine


! Program to test array valued dummy functions
SUBROUTINE dummyfn(deriv)
   implicit none
   INTERFACE
      FUNCTION deriv()
         REAL :: deriv(4)
      END FUNCTION deriv
   END INTERFACE

   REAL :: dx(4)

   dx = deriv()
END SUBROUTINE


module functions_mod
    implicit none

    private
    public :: f1, f2

contains

    function f1(x) result(y)
        implicit none
        real, value :: x
        real :: y

        y = 2.0*x + 3.0
    end function f1

    function f2(x) result(y)
        implicit none
        real, value :: x
        real :: y

        y = 3.0*x + 1.0
    end function f2

end module functions_mod


*     MC01MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          DPMAX
      PARAMETER        ( DPMAX = 20 )
*     .. Local Scalars ..
      DOUBLE PRECISION ALPHA
      INTEGER          DP, I, INFO, K
*     .. Local Arrays ..
      DOUBLE PRECISION P(DPMAX+1), Q(DPMAX+1)
*     .. External Subroutines ..
      EXTERNAL         MC01MD
*     .. Executable Statements ..
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) DP, ALPHA, K
      IF ( DP.LE.-1 .OR. DP.GT.DPMAX ) THEN
         WRITE ( NOUT, FMT = 99995 ) DP
      ELSE
         READ ( NIN, FMT = * ) ( P(I), I = 1,DP+1 )
*        Compute the leading K coefficients of the shifted polynomial.
         CALL MC01MD( DP, ALPHA, K, P, Q, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99997 ) ALPHA
            DO 20 I = 1, K
               WRITE ( NOUT, FMT = 99996 ) I - 1, Q(I)
   20       CONTINUE
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MC01MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MC01MD = ',I2)
99997 FORMAT (' ALPHA = ',F8.4,//' The coefficients of the shifted pol',
     $       'ynomial are ',//' power of (x-ALPHA)     coefficient ')
99996 FORMAT (5X,I5,15X,F9.4)
99995 FORMAT (/' DP is out of range.',/' DP = ',I5)
      END


module module_my_struct

  type my_struct
     real(8) :: x
     integer :: i
  end type my_struct
end

program main  ! ring with derived datatype

  use module_my_struct
  implicit none
  include 'mpif.h'
  integer :: size, rank, ierr
  integer :: partner_left, partner_right
  integer :: len(2), type(2), my_type
  integer(MPI_ADDRESS_KIND) :: disp(2)

  type(my_struct) :: sum, sbuf, rbuf

  call mpi_init(ierr)
  call mpi_comm_size(MPI_COMM_WORLD, size, ierr)
  call mpi_comm_rank(MPI_COMM_WORLD, rank, ierr)

  partner_left  = mod(rank - 1 + size, size)
  partner_right = mod(rank + 1, size)

  len(1) = 1
  len(2) = 1

  call mpi_get_address(sum%x, disp(1), ierr)
  call mpi_get_address(sum%i, disp(2), ierr)

  disp(2) = disp(2) - disp(1)
  disp(1) = disp(1) - disp(1)

  type(1) = MPI_REAL8
  type(2) = MPI_INTEGER

  call mpi_type_create_struct(2, len, disp, type, my_type, ierr)
  call mpi_type_commit(my_type, ierr)

  sum%x = 0
  sum%i = 0
  sbuf%x = rank
  sbuf%i = rank

  do
     call mpi_sendrecv(sbuf, 1, my_type, partner_right, 0, &
                       rbuf, 1, my_type, partner_left, 0, &
                       MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr)
     sum%x = sum%x + rbuf%x
     sum%i = sum%i + rbuf%i
     sbuf%x = rbuf%x
     sbuf%i = rbuf%i
     if (rbuf%i == rank) exit
  enddo

  write(6,*) "sums on rank ", rank, ": ", sum%x, sum%i

  call mpi_finalize(ierr)
end


      SUBROUTINE FPEAUTF(L,N,SD,CXX,SSD,FPE,RFPE,D,CHI2,
     & OFPE1,OFPE2,ORFPE,MO,OSD,A,AO)
C
      INCLUDE 'timsac_f.h'
C
C     PROGRAM 5.3.1   FPE AUTO
C-----------------------------------------------------------------------
C     ** DESIGNED BY H. AKAIKE, THE INSTITUTE OF STATISTICAL MATHEMATICS
C     ** PROGRAMMED BY E. ARAHATA, THE INSTITUTE OF STATISTICAL MATHEMAT
C         TOKYO
C     ** DATE OF THE LATEST REVISION: MARCH 25, 1977
C     ** THIS PROGRAM WAS ORIGINALLY PUBLISHED IN
C         "DAINAMIKKU SISTEMU NO TOKEI-TEKI KAISEKI TO SEIGYO (STATISTICA
C         ANALYSIS AND CONTROL OF DYNAMIC SYSTEMS)" BY H. AKAIKE AND
C         T. NAKAGAWA, SAIENSU-SHA, TOKYO, 1972 (IN JAPANESE)
C-----------------------------------------------------------------------
C     THIS PROGRAM PERFORMS FPE(FINAL PREDICTION ERROR) COMPUTATION FOR
C     ONE-DIMENSIONAL AR-MODEL. A CARD CONTAINING THE FOLLOWING
C     INFORMATION OF L, UPPER LIMIT OF MODEL ORDER, SHOULD BE ADDED ON
C     TOP OF THE OUTPUT OF PROGRAM 5.1.1 AUTCOR TO FORM THE INPUT TO
C     THIS PROGRAM.
C     CXX(0) IS READ AS INITIAL SD.
C     THE OUTPUTS ARE THE COEFFICIENTS A(I) OF AR-PROCESS
C     X(N)=A(1)X(N-1)+...+A(M)X(N-M)+E(N)
C     AND THE VARIANCE SIGMA**2 OF E(N).
C     CHI**2 SHOWS THE SIGNIFICANCE OF PARCOR=A(M) AS A CHI-SQUARED
C     VARIABLE WITH D.F.=1.
C
cc      !DEC$ ATTRIBUTES DLLEXPORT :: FPEAUTF
c      USE DFLIB
C
cxx      IMPLICIT REAL*8(A-H,O-Z)
c      DIMENSION CXX(501),A(501),B(501),AO(501)
cxx      DIMENSION CXX(L),A(L,L),B(L),AO(L)
cxx      DIMENSION SSD(L),FPE(L),RFPE(L),D(L),CHI2(L)
      INTEGER :: L, N, MO
      REAL(8) :: SD, CXX(L), SSD(L), FPE(L), RFPE(L), D(L), CHI2(L),
     1           OFPE1, OFPE2, ORFPE, OSD, A(L,L), AO(L)
      REAL(8) :: B(L), AN, ANP1, ANM1, CST1, OOFPE, SE, SD0, D2
C
C     INPUT / OUTPUT DATA FILE OPEN
c      CHARACTER(100) DFNAM
c      CALL SETWND
c      DFNAM='fpeaut.out'
c      CALL FLOPN3(DFNAM,NFL)
c      IF (NFL.EQ.0) GO TO 999
C     L SPECIFICATION
c      READ(5,1) L
C     READING THE OUTPUT OF PROGRAM 5.1.1 AUTCOR
c      READ(5,1) N,LAGH
c      READ(5,2) SD,(CXX(I),I=1,LAGH)
C
C     COMPUTATION START
      AN=N
      NP1=N+1
      NM1=N-1
      ANP1=NP1
      ANM1=NM1
c      OFPE=(ANP1/ANM1)*SD
      OFPE1=(ANP1/ANM1)*SD
      CST1=1.0D-00
c      OOFPE=CST1/OFPE
      OOFPE=CST1/OFPE1
      ORFPE=CST1
      OSD=SD
      MO=0
      OFPE2=OFPE1
c      WRITE(6,155)
c      WRITE(6,156)
c      WRITE(6,57) N,L
c      WRITE(6,140)
c      WRITE(6,141) SD
c      CALL PRCOL1(CXX,1,L,0)
c      WRITE(6,157)
c      WRITE(6,58) OFPE
      SE=CXX(1)
      SD0=SD
C
      DO 400 M=1,L
      MP1=M+1
c      D=SE/SD
c      A(M)=D
c      D2=D*D
c      SD=(CST1-D2)*SD
      D(M)=SE/SD0
      A(M,M)=D(M)
      D2=D(M)*D(M)
      SSD(M)=(CST1-D2)*SD0
      SD0=SSD(M)
      ANP1=NP1+M
      ANM1=NM1-M
c      FPE=(ANP1/ANM1)*SD
c      RFPE=FPE*OOFPE
c      CHI2=D2*ANM1
      FPE(M)=(ANP1/ANM1)*SSD(M)
      RFPE(M)=FPE(M)*OOFPE
      CHI2(M)=D2*ANM1
      IF(M.EQ.1) GO TO 410
C     A(I) COMPUTATION
      LM=M-1
      DO 420 I=1,LM
c  420 A(I)=A(I)-D*B(I)
      A(I,M)=A(I,M-1)-D(M)*B(I)
  420 CONTINUE
c  410 DO 421 I=1,M
  410 CONTINUE
      DO 421 I=1,M
      IM=MP1-I
c  421 B(I)=A(IM)
      B(I)=A(IM,M)
  421 CONTINUE
c      WRITE(6,60) M
c      WRITE(6,61) SD,FPE,RFPE
c      WRITE(6,62) D,CHI2
c      WRITE(6,160)
c      CALL PRCOL1(A,1,M,0)
C
c      IF(OFPE.LT.FPE) GO TO 440
c      OFPE=FPE
c      ORFPE=RFPE
c      OSD=SD
      IF(OFPE2.LT.FPE(M)) GO TO 440
      OFPE2=FPE(M)
      ORFPE=RFPE(M)
      OSD=SSD(M)
      MO=M
      DO 430 I=1,M
c  430 AO(I)=A(I)
cxx  430 AO(I)=A(I,M)
      AO(I)=A(I,M)
  430 CONTINUE
  440 IF(M.EQ.L) GO TO 400
      SE=CXX(MP1)
      DO 441 I=1,M
cxx  441 SE=SE-B(I)*CXX(I)
      SE=SE-B(I)*CXX(I)
  441 CONTINUE
  400 CONTINUE
C
c      WRITE(6,63) OFPE,MO
c      WRITE(6,64) ORFPE
c      WRITE(7,1) N,MO
c      WRITE(7,2) OSD
c      IF(MO.LE.0) GO TO 699
c      WRITE(7,2) (AO(I),I=1,MO)
c  699 CONTINUE
c      CALL FLCLS3(NFL)
c    1 FORMAT(10I5)
c    2 FORMAT(4D20.10)
c   57 FORMAT(1H ,2HN=,I5,5X,2HL=,I5)
c   58 FORMAT(1H ,5HOFPE=,D12.5)
c   60 FORMAT(1H ,2HM=,I5)
c   61 FORMAT(1H ,9HSIGMA**2=,D12.5,2X,4HFPE=,D12.5,2X,5HRFPE=,D12.5)
c   62 FORMAT(1H ,7HPARCOR=,D14.5,2X,15HCIH**2(D.F.=1)=,D12.5)
c  160 FORMAT(1H ,4X,1HI,12X,4HA(I))
c   63 FORMAT(1H ,13HMINIMUM FPE =,D12.5,2X,14HATTAINED AT M=,I5)
c   64 FORMAT(1H ,13HMINIMUM RFPE=,D12.5)
c  140 FORMAT(1H ,4X,1HI,5X,15HAUTO COVARIANCE)
c  141 FORMAT(1H ,4X,1H0,D16.5)
c  155 FORMAT(1H ,24HPROGRAM 5.3.1   FPE AUTO)
c  156 FORMAT(1H ,17HINITIAL CONDITION)
c  157 FORMAT(1H ,2HM=,4X,1H0)
      RETURN
      END SUBROUTINE


module mod_bound

  use mod_param

  implicit none

  private
  public bounduvw,boundp,boundc, boundfu,boundfv,boundfw, boundsls,boundj,boundmls,boundvof, &
         updthalos, updthalos_1d, updthalos_ls, updthalos_mls

contains

  !-------------------------
  !
  subroutine bounduvw(u,v,w)

    use mpi
    use mod_common
    use mod_common_mpi

    integer :: i,j,k
    real :: frontbound,backbound, coory,coorz
    real :: v_lower,v_upper
    real, dimension(0:,0:,0:) :: u,v,w

    select case(BC_in_z)
    case('Dirichl')

       if (ns_np) then
          v_lower = 0.0
          v_upper = 0.0
       else
          v_lower =-1.5  ! lower plate velocity
          v_upper = 1.5  ! upper plate velocity
       endif

       do j=0,j1
          do i=0,i1
             u(i,j,0)    = -u(i,j,1)                ! no-slip
             u(i,j,k1)   = -u(i,j,kmax)             ! no-slip
             v(i,j,0)    = 2.*v_lower - v(i,j,1)    ! prescribed
             v(i,j,k1)   = 2.*v_upper - v(i,j,kmax) ! prescribed
             w(i,j,0)    = 0.                       ! no-penetration
             w(i,j,kmax) = 0.                       ! no-penetration
             w(i,j,k1)   = w(i,j,kmax-1)            ! not used
          enddo
       enddo

    case('shr-drv')

       v_lower = 0.  ! lower plate velocity
       v_upper = 1.  ! upper plate *shear rate* for v

       do j=0,j1
          do i=0,i1
             u(i,j,0)    = -u(i,j,1)                ! no-slip
             u(i,j,k1)   = -u(i,j,kmax)             ! no-slip
             v(i,j,0)    = 2.*v_lower - v(i,j,1)    ! prescribed
             v(i,j,k1)   = v(i,j,kmax) + dz*v_upper ! prescribed normal derivative
             w(i,j,0)    = 0.                       ! no-penetration
             w(i,j,kmax) = 0.                       ! no-penetration
             w(i,j,k1)   = w(i,j,kmax-1)            ! not used
          enddo
       enddo

    end select

    ! pass x halo data

    call updthalos(u,1)
    call updthalos(v,1)
    call updthalos(w,1)

    ! pass y halo data

    call updthalos(u,2)
    call updthalos(v,2)
    call updthalos(w,2)

    select case(BC_in_y)
    case('Walls')

       frontbound  = (coords(2)  )*ly/(1.*dims(2)) ! front boundary of process myid
       backbound   = (coords(2)+1)*ly/(1.*dims(2)) ! back  boundary of process myid

       if (frontbound .eq. 0.) then
          do k=1,kmax
             coorz = (k - 0.5)*dz/lz
             do i=1,imax

                u(i,0,k) = -u(i,1,k)
                w(i,0,k) = -w(i,1,k)
                v(i,0,k) = 0.

             enddo
          enddo
       endif

       if (backbound .eq. ly) then
          do k=1,kmax
             do i=1,imax

                u(i,j1,k) = -u(i,jmax,k)
                v(i,jmax,k) = 0.
                v(i,j1,k) = v(i,jmax,k)
                w(i,j1,k) = -w(i,jmax,k)

             enddo
          enddo
       endif

    case('InOut')

       frontbound  = (coords(2)  )*ly/(1.*dims(2)) ! front boundary of process myid
       backbound   = (coords(2)+1)*ly/(1.*dims(2)) ! back  boundary of process myid

       if (frontbound .eq. 0.) then
          do k=1,kmax
             coorz = (k - 0.5)*dz/lz
             do i=1,imax

                u(i,0,k) = -u(i,1,k)
                w(i,0,k) = -w(i,1,k)
                v(i,0,k) = v_inflow(i,k)                          ! specified inflow profile
                !v(i,0,k) = 6.*v_bulk_desired*coorz*(1.-coorz)     ! Poiseuille flow

             enddo
          enddo
       endif

       if (backbound .eq. ly) then
          do k=1,kmax
             do i=1,imax

                u(i,j1,k) = u(i,jmax,k)
                v(i,j1,k) = 2.*v(i,jmax,k)-v(i,jmax-1,k)  ! compatible div-free
                w(i,j1,k) = w(i,jmax,k)

             enddo
          enddo
       endif

    case('OutOut')

       frontbound  = (coords(2)  )*ly/(1.*dims(2)) ! front boundary of process myid
       backbound   = (coords(2)+1)*ly/(1.*dims(2)) ! back  boundary of process myid

       if (frontbound .eq. 0.) then
          do k=1,kmax
             do i=1,imax

                u(i,0,k) = u(i,1,k)
                w(i,0,k) = w(i,1,k)
                v(i,0,k) = v(i,1,k) + dy/dz*(w(i,1,k)-w(i,1,k-1))  ! div-free zero-Neumann

             enddo
          enddo
       endif

       if (backbound .eq. ly) then
          do k=1,kmax
             do i=1,imax

                u(i,j1,k) = u(i,jmax,k)
                v(i,j1,k) = 2.*v(i,jmax,k)-v(i,jmax-1,k)  ! compatible div-free
                w(i,j1,k) = w(i,jmax,k)

             enddo
          enddo
       endif

    end select

    return
  end subroutine bounduvw

  !-------------------
  !
  subroutine boundp(p)

    use mpi
    use mod_common_mpi

    integer :: i,j,k
    real, dimension(0:,0:,0:) :: p
    real :: frontbound,backbound

    !$omp parallel default(none) shared(p) private(i,j)
    !$omp do
    do j=0,j1
       do i=0,i1
          p(i,j,0) = p(i,j,1)     ! Newmann (consistent with no/free-slip)
          p(i,j,k1) = p(i,j,kmax) ! Newmann (consistent with no/free-slip)
       enddo
    enddo
    !$omp end parallel

    ! pass x and y halo data

    call updthalos(p,1)
    call updthalos(p,2)

    select case(BC_in_y)
    case('Walls')

       frontbound  = (coords(2)  )*ly/(1.*dims(2)) ! front boundary of process myid
       backbound   = (coords(2)+1)*ly/(1.*dims(2)) ! back  boundary of process myid

       if (frontbound .eq. 0.) then
          do k=1,kmax
             do i=1,imax

                p(i,0,k) = p(i,1,k)  ! zero Neumann

             enddo
          enddo
       endif

       if (backbound .eq. ly) then
          do k=1,kmax
             do i=1,imax

                p(i,j1,k) = p(i,jmax,k)  ! zero Neumann

             enddo
          enddo
       endif

    case('InOut')

       frontbound  = (coords(2)  )*ly/(1.*dims(2)) ! front boundary of process myid
       backbound   = (coords(2)+1)*ly/(1.*dims(2)) ! back  boundary of process myid

       if (frontbound .eq. 0.) then
          do k=1,kmax
             do i=1,imax

                p(i,0,k) = p(i,1,k)  ! zero Neumann

             enddo
          enddo
       endif

       if (backbound .eq. ly) then
          do k=1,kmax
             do i=1,imax

                p(i,j1,k) = -p(i,jmax,k)  ! zero Dirichlet

             enddo
          enddo
       endif

    case('OutOut')

       frontbound  = (coords(2)  )*ly/(1.*dims(2)) ! front boundary of process myid
       backbound   = (coords(2)+1)*ly/(1.*dims(2)) ! back  boundary of process myid

       if (frontbound .eq. 0.) then
          do k=1,kmax
             do i=1,imax

                p(i,0,k) = -p(i,1,k)  ! zero Dirichlet

             enddo
          enddo
       endif

       if (backbound .eq. ly) then
          do k=1,kmax
             do i=1,imax

                p(i,j1,k) = -p(i,jmax,k)  ! zero Dirichlet

             enddo
          enddo
       endif

    end select

    return
  end subroutine boundp

  !----------------------
  !
  subroutine boundc(curv)

    real, dimension(0:,0:,0:) :: curv

    ! do nothing in the wall normal direction

    ! pass x and y halo data

    call updthalos(curv,1)
    call updthalos(curv,2)

    return
  end subroutine boundc

  !------------------------
  !
  subroutine boundfu(flux)

    use mpi
    use mod_common_mpi

    integer :: i,j,k
    real, dimension(-2:,-2:,-2:) :: flux

    write(*,*) '---------------------'
    write(*,*) 'Bummer! WENO5 is not fully implemented yet (ghost points).'
    write(*,*) 'It may produce erroneous results when used with Inflow/Outflow B.C. or at high Re.'
    write(*,*) 'This should be fixed later.'
    write(*,*) 'Program aborted.'
    stop

    !if(isfreeslip) then
    if (.not. ns_np) then
       do j=0,j1
          do i=0,i1
             flux(i,j,0)    = flux(i,j,1)
             flux(i,j,k1)   = flux(i,j,kmax)
          enddo
       enddo
    else
       do j=0,j1
          do i=0,i1
             flux(i,j,0)    = -flux(i,j,1)
             flux(i,j,k1)   = -flux(i,j,kmax)
          enddo
       enddo
    endif

    !-- Periodic BC in x and y --!

    call updthalos_ls(flux,1)
    call updthalos_ls(flux,2)

    return
  end subroutine boundfu

  subroutine boundfv(flux)

    use mpi
    use mod_common_mpi

    integer :: i,j,k
    real, dimension(-2:,-2:,-2:) :: flux

    return
  end subroutine boundfv

  !-----------------------
  !
  subroutine boundfw(flux)

    use mpi
    use mod_common_mpi

    integer :: i,j,k
    real, dimension(-2:,-2:,-2:) :: flux

    !-- Periodic BC in x and y --!

    call updthalos_ls(flux,1)
    call updthalos_ls(flux,2)

    return
  end subroutine boundfw

  !-------------------------
  !
  subroutine boundsls(y_sls)

    use mpi
    use mod_common_mpi
    use mod_common

    integer :: i,j,k
    real :: frontbound,backbound, phi,dphidz,d2phidz2
    real, dimension(10) :: phi_v
    real, dimension(-2:,-2:,-2:) :: y_sls
    character(len=4), parameter :: extrap = 'line'

    !-- extrapolation of level set at walls --!

    select case(extrap)

    case('line')

       do j=-2,j1+2
          do i=-2,i1+2

             y_sls(i,j,0)  = 2.*y_sls(i,j,1)- y_sls(i,j,2)
             y_sls(i,j,k1) = 2.*y_sls(i,j,kmax)- y_sls(i,j,kmax-1)

          enddo
       enddo

    case('quad')

       do j=-2,j1+2
          do i=-2,i1+2

             ! lower side

             phi_v = matmul(pseudo_inv_Ab_lower, reshape(y_sls(i-1:i+1,j-1:j+1,1:3), (/27/)))

             phi      = phi_v(1)
             dphidz   = phi_v(4)
             d2phidz2 = phi_v(7)

             y_sls(i,j,0)  = phi - dphidz*dz + 0.5*d2phidz2*dz**2

             ! upper side

             phi_v = matmul(pseudo_inv_Ab_upper, reshape(y_sls(i-1:i+1,j-1:j+1,kmax-2:kmax), (/27/)))

             phi      = phi_v(1)
             dphidz   = phi_v(4)
             d2phidz2 = phi_v(7)

             y_sls(i,j,k1)  = phi + dphidz*dz + 0.5*d2phidz2*dz**2

          enddo
       enddo

    end select

    !-- Periodic BC in x and y --!

    call updthalos_ls(y_sls,1)
    call updthalos_ls(y_sls,2)

    !-- If not periodic in y  --!

    if (open_end_in_y) then

       frontbound  = (coords(2)  )*ly/(1.*dims(2)) ! front boundary of process myid
       backbound   = (coords(2)+1)*ly/(1.*dims(2)) ! back  boundary of process myid

       if (frontbound .eq. 0.) then
          do k=1,kmax
             do i=1,imax

                y_sls(i,0,k) = 2.*y_sls(i,1,k)- y_sls(i,2,k)  ! linear extrapolation
                y_sls(i,-1,k) = 2.*y_sls(i,0,k)- y_sls(i,1,k)
                y_sls(i,-2,k) = 2.*y_sls(i,-1,k)- y_sls(i,0,k)

             enddo
          enddo
       endif

       if (backbound .eq. ly) then
          do k=1,kmax
             do i=1,imax

                y_sls(i,j1,k) = 2.*y_sls(i,jmax,k)- y_sls(i,jmax-1,k)  ! linear extrapolation
                y_sls(i,j1+1,k) = 2.*y_sls(i,j1,k)- y_sls(i,jmax,k)
                y_sls(i,j1+2,k) = 2.*y_sls(i,j1+1,k)- y_sls(i,j1,k)

             enddo
          enddo
       endif

    endif

    return
  end subroutine boundsls

  !----
  subroutine boundj(jump)

    use mpi
    use mod_common_mpi
    use mod_newtypes

    type(real_3by3_matrix), dimension(-2:,-2:,-2:) :: jump
    real ,dimension(-2:i1+2,-2:j1+2,-2:k1+2) :: temp
    integer :: i,j

    do i = 1,3
       do j = 1,3

          temp(:,:,:) = jump(:,:,:)%grad(i,j)

          !-- Periodic BC in x and y --!

          call updthalos_ls(temp,1)
          call updthalos_ls(temp,2)

          jump(:,:,:)%grad(i,j) = temp(:,:,:)

       enddo
    enddo

    return
  end subroutine boundj

  !-------------------------
  !
  subroutine boundmls(y_mls)

    use mpi
    use mod_common_mpi
    use mod_common

    integer :: i,j,k,l
    real :: frontbound,backbound, phi,dphidz,d2phidz2
    real, dimension(10) :: phi_v
    real, dimension(-2:,-2:,-2:,1:) :: y_mls
    real ,dimension(-2:i1+2,-2:j1+2,-2:k1+2) :: y_temp
    character(len=4), parameter :: extrap = 'line'

    !-- extrapolation of level set at walls --!

    do l=1,lmax

       select case(extrap)

       case('line')

          do j=-2,j1+2
             do i=-2,i1+2

                y_mls(i,j, 0,l)  = 2.*y_mls(i,j, 1,l)- y_mls(i,j,2,l)
                y_mls(i,j,-1,l)  = 2.*y_mls(i,j, 0,l)- y_mls(i,j,1,l)
                y_mls(i,j,-2,l)  = 2.*y_mls(i,j,-1,l)- y_mls(i,j,0,l)

                y_mls(i,j,k1,  l) = 2.*y_mls(i,j,kmax,l)- y_mls(i,j,kmax-1,l)
                y_mls(i,j,k1+1,l) = 2.*y_mls(i,j,k1  ,l)- y_mls(i,j,kmax  ,l)
                y_mls(i,j,k1+2,l) = 2.*y_mls(i,j,k1+1,l)- y_mls(i,j,k1    ,l)

             enddo
          enddo

       case('quad')

          y_temp(:,:,:) = y_mls(:,:,:,l)

          do j=-2,j1+2
             do i=-2,i1+2

                ! lower side

                phi_v = matmul(pseudo_inv_Ab_lower, reshape(y_temp(i-1:i+1,j-1:j+1,1:3), (/27/)))

                phi      = phi_v(1)
                dphidz   = phi_v(4)
                d2phidz2 = phi_v(7)

                y_mls(i,j,0,l)  = phi - dphidz*dz + 0.5*d2phidz2*dz**2

                ! upper side

                phi_v = matmul(pseudo_inv_Ab_upper, reshape(y_temp(i-1:i+1,j-1:j+1,kmax-2:kmax), (/27/)))

                phi      = phi_v(1)
                dphidz   = phi_v(4)
                d2phidz2 = phi_v(7)

                y_mls(i,j,k1,l)  = phi + dphidz*dz + 0.5*d2phidz2*dz**2

             enddo
          enddo

       end select

    enddo

    !-- Periodic BC in x and y --!

    do l=1,lmax
       y_temp(:,:,:) = y_mls(:,:,:,l)
       call updthalos_ls(y_temp,1)
       call updthalos_ls(y_temp,2)
       y_mls(:,:,:,l) = y_temp(:,:,:)
    enddo

    !-- If not periodic in y  --!

    if (open_end_in_y) then

       frontbound  = (coords(2)  )*ly/(1.*dims(2)) ! front boundary of process myid
       backbound   = (coords(2)+1)*ly/(1.*dims(2)) ! back  boundary of process myid

       if (frontbound .eq. 0.) then
          do l=1,lmax
             do k=1,kmax
                do i=1,imax

                   y_mls(i,0,k,l) = 2.*y_mls(i,1,k,l)- y_mls(i,2,k,l)  ! linear extrapolation

                enddo
             enddo
          enddo
       endif

       if (backbound .eq. ly) then
          do l=1,lmax
             do k=1,kmax
                do i=1,imax

                   y_mls(i,j1,k,l) = 2.*y_mls(i,jmax,k,l)- y_mls(i,jmax-1,k,l)  ! linear extrapolation

                enddo
             enddo
          enddo
       endif

    endif

    return
  end subroutine boundmls

  !--------------------------
  !
  subroutine boundvof(y_mvof)

    use mpi
    use mod_common_mpi

    integer :: l
    real, dimension(0:,0:,0:,1:) :: y_mvof
    real ,dimension(0:i1,0:j1,0:k1) :: vof_temp

    !-- Periodic BC in x and y --!

    do l=1,lmax
       vof_temp(:,:,:) = y_mvof(:,:,:,l)
       call updthalos(vof_temp,1)
       call updthalos(vof_temp,2)
       y_mvof(:,:,:,l) = vof_temp(:,:,:)
    enddo

    return
  end subroutine boundvof

  !~~~~~~~~~~~~~~~~!
  !                !
  !  Halo passing  !
  !                !
  !~~~~~~~~~~~~~~~~!

  subroutine updthalos(var,dir)

    use mpi
    use mod_common_mpi

    real, dimension(0:,0:,0:), intent(inout) :: var
    integer, intent(in) :: dir
    integer :: requests(4), statuses(MPI_STATUS_SIZE,4)

    !  This subroutine updates the halos that store info
    !  from the neighboring computational sub-domain

    select case(dir)
    case(1) ! x direction
       call MPI_SENDRECV(var(1,0,0),1,xhalo,left,0,   &
                         var(i1,0,0),1,xhalo,right,0, &
                         comm_cart,status,error)
       call MPI_SENDRECV(var(imax,0,0),1,xhalo,right,0, &
                         var(0,0,0),1,xhalo,left,0,     &
                         comm_cart,status,error)
       !call MPI_IRECV(var(0,0,0),1,xhalo,left,1, &
       !               comm_cart,requests(2),error)
       !call MPI_IRECV(var(i1,0,0),1,xhalo,right,0, &
       !               comm_cart,requests(1),error)
       !call MPI_ISSEND(var(imax,0,0),1,xhalo,right,1, &
       !               comm_cart,requests(4),error)
       !call MPI_ISSEND(var(1,0,0),1,xhalo,left,0, &
       !               comm_cart,requests(3),error)
       !call MPI_WAITALL(4, requests, statuses, error)
    case(2) ! y direction
       call MPI_SENDRECV(var(0,1,0),1,yhalo,front,0, &
                         var(0,j1,0),1,yhalo,back,0, &
                         comm_cart,status,error)
       call MPI_SENDRECV(var(0,jmax,0),1,yhalo,back,0, &
                         var(0,0,0),1,yhalo,front,0,   &
                         comm_cart,status,error)
       !call MPI_IRECV(var(0,j1,0),1,yhalo,back,0, &
       !               comm_cart,requests(1),error)
       !call MPI_IRECV(var(0,0,0),1,yhalo,front,1, &
       !               comm_cart,requests(2),error)
       !call MPI_ISSEND(var(0,1,0),1,yhalo,front,0, &
       !               comm_cart,requests(3),error)
       !call MPI_ISSEND(var(0,jmax,0),1,yhalo,back,1, &
       !               comm_cart,requests(4),error)
       !call MPI_WAITALL(4, requests, statuses, error)
    end select

    return
  end subroutine updthalos

  subroutine updthalos_1d(var,dir)

    use mpi
    use mod_common_mpi

    real, dimension(0:), intent(inout) :: var
    integer, intent(in) :: dir
    integer :: requests(4), statuses(MPI_STATUS_SIZE,4)

    !  This subroutine updates the halos of a 1D array
    !
    !  It uses ?halo_1d defined in initmpi.f90

    select case(dir)
    case(1) ! x direction

       call MPI_SENDRECV(var(1),1,xhalo_1d,left, 0, &
            var(i1),1,xhalo_1d,right,0, &
            comm_cart,status,error)

       call MPI_SENDRECV(var(imax),1,xhalo_1d,right,0, &
            var(0),1,xhalo_1d,left,0, &
            comm_cart,status,error)

    case(2) ! y direction
       call MPI_SENDRECV(var(1),1,yhalo_1d,front,0, &
            var(j1),1,yhalo_1d,back,0, &
            comm_cart,status,error)

       call MPI_SENDRECV(var(jmax),1,yhalo_1d,back,0, &
            var(0),1,yhalo_1d,front,0, &
            comm_cart,status,error)

    end select

    return
  end subroutine updthalos_1d

  subroutine updthalos_ls(var,dir)

    use mpi
    use mod_common_mpi

    real, dimension(-2:,-2:,-2:), intent(inout) :: var
    integer, intent(in) :: dir
    integer :: requests(4), statuses(MPI_STATUS_SIZE,4)

    !  This subroutine updates the halos that store level set
    !  from the neighboring computational sub-domain
    !
    !  It uses ?halo_ls defined in initmpi.f90

    select case(dir)
    case(1) ! x direction

       call MPI_SENDRECV(var(1,-2,-2), 1,xhalo_ls,left, 0, &
            var(i1,-2,-2),1,xhalo_ls,right,0, &
            comm_cart,status,error)

       call MPI_SENDRECV(var(imax-2,-2,-2),1,xhalo_ls,right,0, &
            var(-2,-2,-2),    1,xhalo_ls,left, 0, &
            comm_cart,status,error)

    case(2) ! y direction
       call MPI_SENDRECV(var(-2,1,-2), 1,yhalo_ls,front,0, &
            var(-2,j1,-2),1,yhalo_ls,back, 0, &
            comm_cart,status,error)

       call MPI_SENDRECV(var(-2,jmax-2,-2),1,yhalo_ls,back, 0, &
            var(-2,-2,-2),    1,yhalo_ls,front,0, &
            comm_cart,status,error)

    end select

    return
  end subroutine updthalos_ls

  subroutine updthalos_mls(var,dir,l)

    use mpi
    use mod_common_mpi

    real, dimension(-2:,-2:,-2:,1:), intent(inout) :: var
    integer, intent(in) :: dir, l
    integer :: requests(4), statuses(MPI_STATUS_SIZE,4)

    !  This subroutine updates the halos that store multiple level set
    !  from the neighboring computational sub-domain
    !
    !  It uses ?halo_ls defined in initmpi.f90

    select case(dir)
    case(1) ! x direction

       call MPI_SENDRECV(var(1,-2,-2,l), 1,xhalo_ls,left, 0, &
            var(i1,-2,-2,l),1,xhalo_ls,right,0, &
            comm_cart,status,error)

       call MPI_SENDRECV(var(imax-2,-2,-2,l),1,xhalo_ls,right,0, &
            var(-2,-2,-2,l),    1,xhalo_ls,left, 0, &
            comm_cart,status,error)

    case(2) ! y direction
       call MPI_SENDRECV(var(-2,1,-2,l), 1,yhalo_ls,front,0, &
            var(-2,j1,-2,l),1,yhalo_ls,back, 0, &
            comm_cart,status,error)

       call MPI_SENDRECV(var(-2,jmax-2,-2,l),1,yhalo_ls,back, 0, &
            var(-2,-2,-2,l),    1,yhalo_ls,front,0, &
            comm_cart,status,error)

    end select

    return
  end subroutine updthalos_mls

end module mod_bound


program testpes
use surface1
use callpot1

implicit none
real*8 :: roo, roc, rco, ener1
real*8, dimension(:) :: dvdr(3), r(3)

!      3
!      O
!     / \
!  r3/   \r2
!   /     \
!  /       \
! C---------O
! 1   r1    2

roo=4.4d0 !in bohr
roc=2.3d0 !in bohr
rco=2.3d0 !in bohr

r(1)=rco
r(2)=roo
r(3)=roc

call co21appes(r, ener1, dvdr)

write(*,*)"Energy = ", ener1, "Hartree"
write(*,*)"dV/dr_i (Hartree/bohr) = ", dvdr

end


!
! Copyright 2020-2022 Fluid Numerics LLC
! Author : Joseph Schoonover (joe@fluidnumerics.com)
! Support : support@fluidnumerics.com
!
! //////////////////////////////////////////////////////////////////////////////////////////////// !
MODULE SELF_LinearShallowWater

  USE SELF_Metadata
  USE SELF_Mesh
  USE SELF_MappedData
  USE SELF_Model

  TYPE,EXTENDS(Model2D) :: LinearShallowWater
    !! iVar = 1 ~> u velocity component
    !! iVar = 2 ~> v velocity component
    !! iVar = 3 ~> free surface height
    REAL(prec) :: fCori ! coriolis parameter ( 1/s )
    REAL(prec) :: g     ! gravity ( m/s^2)
    REAL(prec) :: H     ! fluid thickness ( m )

    CONTAINS

    ! Concretized Methods
    PROCEDURE :: Source2D => Source_LinearShallowWater
    PROCEDURE :: Flux2D => Flux_LinearShallowWater
    PROCEDURE :: RiemannSolver2D => RiemannSolver_LinearShallowWater
    PROCEDURE :: SetBoundaryCondition => SetBoundaryCondition_LinearShallowWater

  END TYPE LinearShallowWater

  INTERFACE
    SUBROUTINE Flux_LinearShallowWater_gpu_wrapper(flux, solution, g, H, N, nVar, nEl) &
      bind(c,name="Flux_LinearShallowWater_gpu_wrapper")
      USE iso_c_binding
      USE SELF_Constants
      IMPLICIT NONE
      TYPE(c_ptr) :: flux, solution
      INTEGER(C_INT),VALUE :: N,nVar,nEl
      REAL(c_prec),VALUE :: g, H
    END SUBROUTINE Flux_LinearShallowWater_gpu_wrapper
  END INTERFACE

CONTAINS

  SUBROUTINE SetBoundaryCondition_LinearShallowWater(this)
    IMPLICIT NONE
    CLASS(LinearShallowWater),INTENT(inout) :: this
    ! Local
    INTEGER :: iEl, iSide, i
    INTEGER :: bcid
    REAL(prec) :: u, v, nhat(1:2)

    DO iEl = 1, this % solution % nElem
      DO iSide = 1, 4
          DO i = 0, this % solution % interp % N

            bcid = this % mesh % self_sideInfo % hostData(5,iSide,iEl) ! Boundary Condition ID
            IF( bcid == SELF_BC_RADIATION )THEN

              this % solution % extBoundary % hostData(i,1,iSide,iEl) = 0.0_prec
              this % solution % extBoundary % hostData(i,2,iSide,iEl) = 0.0_prec
              this % solution % extBoundary % hostData(i,3,iSide,iEl) = 0.0_prec

            ELSEIF( bcid == SELF_BC_NONORMALFLOW )THEN

              nhat(1:2) = this % geometry % nHat % boundary % hostData(1:2,i,1,iSide,iEl)
              u = this % solution % boundary % hostData(i,1,iSide,iEl)
              v = this % solution % boundary % hostData(i,2,iSide,iEl)
              this % solution % extBoundary % hostData(i,1,iSide,iEl) = (nhat(2)**2 - nhat(1)**2)*u - 2.0_prec*nhat(1)*nhat(2)*v
              this % solution % extBoundary % hostData(i,2,iSide,iEl) = (nhat(1)**2 - nhat(2)**2)*v - 2.0_prec*nhat(1)*nhat(2)*u
              this % solution % extBoundary % hostData(i,3,iSide,iEl) = this % solution % boundary % hostData(i,3,iSide,iEl)

!            ELSEIF( bcid == SELF_BC_PRESCRIBED )THEN
            ELSE

              PRINT*, "WARNING : Unrecognized boundary condition"

            ENDIF
          ENDDO
      ENDDO
    ENDDO

  END SUBROUTINE SetBoundaryCondition_LinearShallowWater

  SUBROUTINE Source_LinearShallowWater(this)
    IMPLICIT NONE
    CLASS(LinearShallowWater),INTENT(inout) :: this
    ! Local
    INTEGER :: i,j,iEl,iVar

    DO iEl = 1, this % source % nElem
      DO j = 0, this % source % interp % N
        DO i = 0, this % source % interp % N

          this % source % interior % hostData(i,j,1,iEl) = -this % fCori*this % source % interior % hostData(i,j,2,iEl)
          this % source % interior % hostData(i,j,2,iEl) = this % fCori*this % source % interior % hostData(i,j,1,iEl)
          this % source % interior % hostData(i,j,3,iEl) = 0.0_prec

        ENDDO
      ENDDO
    ENDDO

  END SUBROUTINE Source_LinearShallowWater

  SUBROUTINE Flux_LinearShallowWater(this)
    IMPLICIT NONE
    CLASS(LinearShallowWater),INTENT(inout) :: this
    ! Local
    INTEGER :: i,j,iEl,iVar

    IF( this % gpuAccel )THEN

      CALL Flux_LinearShallowWater_gpu_wrapper(this % flux % interior % deviceData,&
                                               this % solution % interior % deviceData, &
                                               this % g, this % H, this % solution % interp % N, &
                                               this % solution % nVar, this % solution % nElem)

    ELSE
      DO iEl = 1, this % solution % nElem
        DO iVar = 1, this % solution % nVar
          DO j = 0, this % solution % interp % N
            DO i = 0, this % solution % interp % N

              IF ( iVar == 1 )THEN ! u-velocity
                this % flux % interior % hostData(1,i,j,iVar,iEl) = &
                      this % g*this % solution % interior % hostData(i,j,3,iEl)

                this % flux % interior % hostData(2,i,j,iVar,iEl) = 0.0_prec

              ELSEIF ( iVar == 2 )THEN ! v-velocity

                this % flux % interior % hostData(1,i,j,iVar,iEl) = 0.0_prec

                this % flux % interior % hostData(2,i,j,iVar,iEl) = &
                      this % g*this % solution % interior % hostData(i,j,3,iEl)

              ELSEIF ( iVar == 3 )THEN ! free surface height
                this % flux % interior % hostData(1,i,j,iVar,iEl) = &
                      this % H*this % solution % interior % hostData(i,j,1,iEl)

                this % flux % interior % hostData(2,i,j,iVar,iEl) = &
                      this % H*this % solution % interior % hostData(i,j,2,iEl)
              ENDIF

            ENDDO
          ENDDO
        ENDDO
      ENDDO
    ENDIF

  END SUBROUTINE Flux_LinearShallowWater

  SUBROUTINE RiemannSolver_LinearShallowWater(this)
    IMPLICIT NONE
    CLASS(LinearShallowWater),INTENT(inout) :: this
    ! Local
    INTEGER :: i,iSide,iEl,iVar
    REAL(prec) :: nhat(1:2), nmag
    REAL(prec) :: c, unL, unR, etaL, etaR, wL, wR

    DO iEl = 1, this % solution % nElem
      DO iSide = 1, 4
          DO i = 0, this % solution % interp % N

             ! Get the boundary normals on cell edges from the mesh geometry
             nhat(1:2) = this % geometry % nHat % boundary % hostData(1:2,i,1,iSide,iEl)
             nmag = this % geometry % nScale % boundary % hostData(i,1,iSide,iEl)
             c = sqrt( this % g * this % H )

             ! Calculate the normal velocity at the cell edges
             unL = this % solution % boundary % hostData(i,1,iSide,iEl)*nHat(1)+&
                   this % solution % boundary % hostData(i,2,iSide,iEl)*nHat(2)

             unR = this % solution % extBoundary % hostData(i,1,iSide,iEl)*nHat(1)+&
                   this % solution % extBoundary % hostData(i,2,iSide,iEl)*nHat(2)

             etaL = this % solution % boundary % hostData(i,3,iSide,iEl)
             etaR = this % solution % extBoundary % hostData(i,3,iSide,iEl)

             ! Pull external and internal state for the Riemann Solver (Lax-Friedrichs)
             wL = 0.5_prec*(etaL/c + unL/this % g)
             wR = 0.5_prec*(etaR/c - unR/this % g)

             this % flux % boundaryNormal % hostData(i,1,iSide,iEl) = this % g*c*( wL - wR )*nHat(1)*nmag
             this % flux % boundaryNormal % hostData(i,2,iSide,iEl) = this % g*c*( wL - wR )*nHat(2)*nmag
             this % flux % boundaryNormal % hostData(i,1,iSide,iEl) = c*c*( wL + wR )*nmag

          ENDDO
      ENDDO
    ENDDO

  END SUBROUTINE RiemannSolver_LinearShallowWater

END MODULE SELF_LinearShallowWater


*DECK DPCHSW
      SUBROUTINE DPCHSW (DFMAX, IEXTRM, D1, D2, H, SLOPE, IERR)
C***BEGIN PROLOGUE  DPCHSW
C***SUBSIDIARY
C***PURPOSE  Limits excursion from data for DPCHCS
C***LIBRARY   SLATEC (PCHIP)
C***TYPE      DOUBLE PRECISION (PCHSW-S, DPCHSW-D)
C***AUTHOR  Fritsch, F. N., (LLNL)
C***DESCRIPTION
C
C         DPCHSW:  DPCHCS Switch Excursion Limiter.
C
C     Called by  DPCHCS  to adjust D1 and D2 if necessary to insure that
C     the extremum on this interval is not further than DFMAX from the
C     extreme data value.
C
C ----------------------------------------------------------------------
C
C  Calling sequence:
C
C        INTEGER  IEXTRM, IERR
C        DOUBLE PRECISION  DFMAX, D1, D2, H, SLOPE
C
C        CALL  DPCHSW (DFMAX, IEXTRM, D1, D2, H, SLOPE, IERR)
C
C   Parameters:
C
C     DFMAX -- (input) maximum allowed difference between F(IEXTRM) and
C           the cubic determined by derivative values D1,D2.  (assumes
C           DFMAX.GT.0.)
C
C     IEXTRM -- (input) index of the extreme data value.  (assumes
C           IEXTRM = 1 or 2 .  Any value .NE.1 is treated as 2.)
C
C     D1,D2 -- (input) derivative values at the ends of the interval.
C           (Assumes D1*D2 .LE. 0.)
C          (output) may be modified if necessary to meet the restriction
C           imposed by DFMAX.
C
C     H -- (input) interval length.  (Assumes  H.GT.0.)
C
C     SLOPE -- (input) data slope on the interval.
C
C     IERR -- (output) error flag.  should be zero.
C           If IERR=-1, assumption on D1 and D2 is not satisfied.
C           If IERR=-2, quadratic equation locating extremum has
C                       negative discriminant (should never occur).
C
C    -------
C    WARNING:  This routine does no validity-checking of arguments.
C    -------
C
C  Fortran intrinsics used:  ABS, SIGN, SQRT.
C
C***SEE ALSO  DPCHCS
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   820218  DATE WRITTEN
C   820805  Converted to SLATEC library version.
C   870707  Corrected XERROR calls for d.p. name(s).
C   870707  Replaced DATA statement for SMALL with a use of D1MACH.
C   870813  Minor cosmetic changes.
C   890206  Corrected XERROR calls.
C   890411  1. Added SAVE statements (Vers. 3.2).
C           2. Added DOUBLE PRECISION declaration for D1MACH.
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   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900328  Added TYPE section.  (WRB)
C   910408  Updated AUTHOR and DATE WRITTEN sections in prologue.  (WRB)
C   920526  Eliminated possible divide by zero problem.  (FNF)
C   930503  Improved purpose.  (FNF)
C***END PROLOGUE  DPCHSW
C
C**End
C
C  DECLARE ARGUMENTS.
C
      INTEGER  IEXTRM, IERR
      DOUBLE PRECISION  DFMAX, D1, D2, H, SLOPE
C
C  DECLARE LOCAL VARIABLES.
C
      DOUBLE PRECISION  CP, FACT, HPHI, LAMBDA, NU, ONE, PHI, RADCAL,
     *                  RHO, SIGMA, SMALL, THAT, THIRD, THREE, TWO, ZERO
      SAVE ZERO, ONE, TWO, THREE, FACT
      SAVE THIRD
      DOUBLE PRECISION  D1MACH
C
      DATA  ZERO /0.D0/,  ONE /1.D0/,  TWO /2.D0/, THREE /3.D0/,
     *      FACT /100.D0/
C        THIRD SHOULD BE SLIGHTLY LESS THAN 1/3.
      DATA  THIRD /0.33333D0/
C
C  NOTATION AND GENERAL REMARKS.
C
C     RHO IS THE RATIO OF THE DATA SLOPE TO THE DERIVATIVE BEING TESTED.
C     LAMBDA IS THE RATIO OF D2 TO D1.
C     THAT = T-HAT(RHO) IS THE NORMALIZED LOCATION OF THE EXTREMUM.
C     PHI IS THE NORMALIZED VALUE OF P(X)-F1 AT X = XHAT = X-HAT(RHO),
C           WHERE  THAT = (XHAT - X1)/H .
C        THAT IS, P(XHAT)-F1 = D*H*PHI,  WHERE D=D1 OR D2.
C     SIMILARLY,  P(XHAT)-F2 = D*H*(PHI-RHO) .
C
C      SMALL SHOULD BE A FEW ORDERS OF MAGNITUDE GREATER THAN MACHEPS.
C***FIRST EXECUTABLE STATEMENT  DPCHSW
      SMALL = FACT*D1MACH(4)
C
C  DO MAIN CALCULATION.
C
      IF (D1 .EQ. ZERO)  THEN
C
C        SPECIAL CASE -- D1.EQ.ZERO .
C
C          IF D2 IS ALSO ZERO, THIS ROUTINE SHOULD NOT HAVE BEEN CALLED.
         IF (D2 .EQ. ZERO)  GO TO 5001
C
         RHO = SLOPE/D2
C          EXTREMUM IS OUTSIDE INTERVAL WHEN RHO .GE. 1/3 .
         IF (RHO .GE. THIRD)  GO TO 5000
         THAT = (TWO*(THREE*RHO-ONE)) / (THREE*(TWO*RHO-ONE))
         PHI = THAT**2 * ((THREE*RHO-ONE)/THREE)
C
C          CONVERT TO DISTANCE FROM F2 IF IEXTRM.NE.1 .
         IF (IEXTRM .NE. 1)  PHI = PHI - RHO
C
C          TEST FOR EXCEEDING LIMIT, AND ADJUST ACCORDINGLY.
         HPHI = H * ABS(PHI)
         IF (HPHI*ABS(D2) .GT. DFMAX)  THEN
C           AT THIS POINT, HPHI.GT.0, SO DIVIDE IS OK.
            D2 = SIGN (DFMAX/HPHI, D2)
         ENDIF
      ELSE
C
         RHO = SLOPE/D1
         LAMBDA = -D2/D1
         IF (D2 .EQ. ZERO)  THEN
C
C           SPECIAL CASE -- D2.EQ.ZERO .
C
C             EXTREMUM IS OUTSIDE INTERVAL WHEN RHO .GE. 1/3 .
            IF (RHO .GE. THIRD)  GO TO 5000
            CP = TWO - THREE*RHO
            NU = ONE - TWO*RHO
            THAT = ONE / (THREE*NU)
         ELSE
            IF (LAMBDA .LE. ZERO)  GO TO 5001
C
C           NORMAL CASE -- D1 AND D2 BOTH NONZERO, OPPOSITE SIGNS.
C
            NU = ONE - LAMBDA - TWO*RHO
            SIGMA = ONE - RHO
            CP = NU + SIGMA
            IF (ABS(NU) .GT. SMALL)  THEN
               RADCAL = (NU - (TWO*RHO+ONE))*NU + SIGMA**2
               IF (RADCAL .LT. ZERO)  GO TO 5002
               THAT = (CP - SQRT(RADCAL)) / (THREE*NU)
            ELSE
               THAT = ONE/(TWO*SIGMA)
            ENDIF
         ENDIF
         PHI = THAT*((NU*THAT - CP)*THAT + ONE)
C
C          CONVERT TO DISTANCE FROM F2 IF IEXTRM.NE.1 .
         IF (IEXTRM .NE. 1)  PHI = PHI - RHO
C
C          TEST FOR EXCEEDING LIMIT, AND ADJUST ACCORDINGLY.
         HPHI = H * ABS(PHI)
         IF (HPHI*ABS(D1) .GT. DFMAX)  THEN
C           AT THIS POINT, HPHI.GT.0, SO DIVIDE IS OK.
            D1 = SIGN (DFMAX/HPHI, D1)
            D2 = -LAMBDA*D1
         ENDIF
      ENDIF
C
C  NORMAL RETURN.
C
 5000 CONTINUE
      IERR = 0
      RETURN
C
C  ERROR RETURNS.
C
 5001 CONTINUE
C     D1 AND D2 BOTH ZERO, OR BOTH NONZERO AND SAME SIGN.
      IERR = -1
      CALL XERMSG ('SLATEC', 'DPCHSW', 'D1 AND/OR D2 INVALID', IERR, 1)
      RETURN
C
 5002 CONTINUE
C     NEGATIVE VALUE OF RADICAL (SHOULD NEVER OCCUR).
      IERR = -2
      CALL XERMSG ('SLATEC', 'DPCHSW', 'NEGATIVE RADICAL', IERR, 1)
      RETURN
C------------- LAST LINE OF DPCHSW FOLLOWS -----------------------------
      END


module ModelParams
	implicit None
	!This is just the camb params used in halofit
	integer, parameter :: dl = 8
    real(dl), parameter :: pi = 3.141592654

	type CambParams
		real(dl) :: omegac
		real(dl) :: omegab
		real(dl) :: omegan
		real(dl) :: omegav
	end type CambParams

	type(CambParams) :: CP
end module

module LambdaGeneral
    use  ModelParams
    implicit none

    real(dl)  :: w_lam = -1_dl !p/rho for the dark energy (assumed constant)
    ! w_lam is now w0
    !comoving sound speed. Always exactly 1 for quintessence
    !(otherwise assumed constant, though this is almost certainly unrealistic)
    real(dl) :: cs2_lam = 1_dl
    !cs2_lam now is ce^2

    logical :: use_tabulated_w = .false.
    real(dl) :: wa_ppf = 0._dl
    real(dl) :: c_Gamma_ppf = 0.4_dl
    integer, parameter :: nwmax = 5000, nde = 2000
    integer :: nw_ppf
    real(dl) w_ppf(nwmax), a_ppf(nwmax), ddw_ppf(nwmax)
    real(dl) rde(nde),ade(nde),ddrde(nde)
    real(dl), parameter :: amin = 1.d-9
    logical :: is_cosmological_constant
    private nde,ddw_ppf,rde,ade,ddrde,amin
end module LambdaGeneral


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine calculated(nktet,d,dmin,ipoed,iedg,cotet)
!
!     determine the length of all edges in the actual mesh
!
      implicit none
!
      integer i,nktet,ipoed(*),iedg(3,*),index,n1,n2
!
      real*8 d(*),dmin,cotet(3,*)
!
!     determine the size of all edges
!
      dmin=1.d30
!
      loop: do i=1,nktet
         index=ipoed(i)
         do
            if(index.eq.0) cycle loop
!
            n1=iedg(1,index)
            n2=iedg(2,index)
!
            d(index)=dsqrt((cotet(1,n1)-cotet(1,n2))**2+
     &                     (cotet(2,n1)-cotet(2,n2))**2+
     &                     (cotet(3,n1)-cotet(3,n2))**2)
!
            if(d(index).lt.dmin) dmin=d(index)
!
            index=iedg(3,index)
         enddo
      enddo loop
!
      return
      end