       SUBROUTINE ZGGES_F95( A, B, ALPHA, BETA, VSL, VSR, SELECT, SDIM, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
      USE LA_PRECISION, ONLY: WP =>  DP
      USE LA_AUXMOD, ONLY: ERINFO, LSAME
      USE F77_LAPACK, ONLY: GGES_F77 => LA_GGES
!  .. IMPLICIT STATEMENT ..
      IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
      INTEGER, INTENT(OUT), OPTIONAL :: INFO
      INTEGER, INTENT(OUT), OPTIONAL :: SDIM
!  .. ARRAY ARGUMENTS ..
      COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:,:)
      COMPLEX(WP), INTENT(OUT) :: ALPHA(:), BETA(:)
      COMPLEX(WP), INTENT(OUT), OPTIONAL, TARGET :: VSL(:,:), VSR(:,:)
!  .. FUNCTIONAL ARGUMENTS ..
      INTERFACE
      LOGICAL FUNCTION SELECT( ALPHA, BETA)
      USE LA_PRECISION, ONLY: WP => DP
      COMPLEX(WP), INTENT(IN) :: ALPHA, BETA
      END FUNCTION SELECT
      END INTERFACE
      OPTIONAL :: SELECT
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!      LA_GGES computes for a pair of n by n real or complex matrices
! (A, B) the (generalized) real or complex Schur form, the generalized
! eigenvalues in the form of scalar pairs (alpha,beta), and, optionally,
! the left and/or right Schur vectors.
!      If A and B are real then the real-Schur form is computed,
! otherwise the complex-Schur form is computed. The real-Schur form is a
! pair of real matrices (S,T) such that 1) S has block upper triangular
! form, with 1 by 1 and 2 by 2 blocks along the main diagonal, 2) T has
! upper triangular form with nonnegative elements on the main diagonal,
! and 3) S = Q^T*A*Z and T = Q^T*B*Z, where Q and Z are orthogonal
! matrices. The 2 by 2 blocks of S are "standardized" by making the
! corresponding elements of T have the form
!                        [ a  0 ]
! 		         [ 0  b ]
! The complex-Schur form is a pair of matrices (S,T) such that 1) S has
! upper triangular form, 2) T has upper triangular form with nonnegative
! elements on the main diagonal, and 3) S = Q^H*A*Z and T = Q^H*B*Z,
! where Q and Z are unitary matrices.
!       In both cases the columns of Q and Z are called, respectively,
! the left and right (generalized) Schur vectors.
! A generalized eigenvalue of the pair (A,B) is, roughly speaking, a
! scalar of the form lambda = alpha/beta such that the matrix
! A -lambda*B is singular. It is usually represented as the pair
! (alpha, beta), as there is a reasonable interpretation of the case
! beta = 0 (even if alpha = 0).
!
! =========
!
!           SUBROUTINE LA_GGES( A, B, <alpha>, BETA, VSL=vsl, &
!                      VSR=vsr, SELECT=select, SDIM=sdim, INFO=info )
!              <type>(<wp>), INTENT(INOUT) :: A(:,:), B(:,:)
!              <type>(<wp>), INTENT(OUT) :: <alpha(:)>, BETA(:)
!              <type>(<wp>), INTENT(OUT), OPTIONAL :: VSL(:,:), VSR(:,:)
!              INTERFACE
!                 LOGICAL FUNCTION SELECT(<alpha(j)> , BETA(j))
!                     <type>(<wp>), INTENT(IN) :: <alpha(j)> , BETA(j)
!                 END FUNCTION SELECT
!              END INTERFACE
!              OPTIONAL :: SELECT
!              INTEGER, INTENT(OUT), OPTIONAL :: SDIM
!              INTEGER, INTENT(OUT), OPTIONAL :: INFO
!           where
!              <type>     ::= REAL | COMPLEX
!              <wp>       ::= KIND(1.0) | KIND(1.0D0)
!              <alpha>    ::= ALPHAR, ALPHAI | ALPHA
!              <alpha(:)> ::= ALPHAR(:), ALPHAI(:) | ALPHA(:)
!              <alpha(j)> ::= ALPHAR(j) , ALPHAI(j) | ALPHA(j)
!
! Arguments
! =========
!
! A        (input/output) REAL or COMPLEX square array, shape (:,:).
!          On entry, the matrix A.
!          On exit, the matrix S.
! B        (input/output) REAL or COMPLEX square array, shape (:,:) with
!          size(B,1) = size(A,1).
!          On entry, the matrix B.
!          On exit, the matrix T .
! <alpha>  (output) REAL or COMPLEX array, shape (:) with size(alpha) =
!          size(A,1).
! 	   The values of alpha.
!          <alpha(:)> ::= ALPHAR(:), ALPHAI(:) | ALPHA(:),
!          where
!          ALPHAR(:), ALPHAI(:) are of REAL type (for the real and
! 	   imaginary parts) and ALPHA(:) is of COMPLEX type.
! BETA     (output) REAL or COMPLEX array, shape (:) with size(BETA) =
!          size(A,1).
!          The values of beta.
!          Note: The generalized eigenvalues of the pair (A,B) are the
! 	   scalars lambda(j) = alpha(j)/beta(j). These quotients may
! 	   easily over- or underflow, and beta(j) may even be zero. Thus,
! 	   the user should avoid computing them naively.
!          Note: If A and B are real then complex eigenvalues occur in
! 	   complex conjugate pairs. Each pair is stored consecutively.
! 	   Thus a complex conjugate pair is given by
!            lambda(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)
!            lambda(j+1) = (ALPHAR(j+1) + i*ALPHAI(j+1))/BETA(j+1)
!          where
!          ALPHAI(j)/BETA(j) = -( ALPHAI(j+1)/BETA(j+1))
! VSL      Optional (output) REAL or COMPLEX square array, shape (:,:)
!          with size(VSL,1) = size(A,1).
!          The left Schur vectors.
! VSR      Optional (output) REAL or COMPLEX square array, shape (:,:)
!          with size(VSR,1) = size(A,1).
!          The right Schur vectors.
! SELECT   Optional (input) LOGICAL FUNCTION
!          LOGICAL FUNCTION SELECT( <alpha(j)> , BETA(j))
!             <type>(<wp>), INTENT(IN) :: <alpha(j)> , BETA(j)
!          where
!             <type> ::= REAL | COMPLEX
!             <wp> ::= KIND(1.0) | KIND(1.0D0)
!             <alpha(j)> ::= ALPHAR(j) , ALPHAI(j) | ALPHA(j)
!          1. SELECT must be declared as EXTERNAL or as an explicit
! 	   interface in the calling (sub)program.
!          2. SELECT is called by LA_GGES for every computed eigenvalue
! 	   (<alpha(j)> , BETA(j)) (but only once for a complex conjugate
! 	   pair when A and B are real). It is used to select the
!          eigenvalues that will be ordered to the top left of the Schur
! 	   form. The eigenvalue (<alpha(j)>, BETA(j)) is selected if
! 	   SELECT(<alpha(j)>, BETA(j)) has the value .TRUE.
!          3. A selected complex eigenvalue may no longer satisfy
! 	   SELECT(<alpha(j)>, BETA(j)) = .TRUE. after ordering, since
! 	   ordering may change the value of complex eigenvalues
! 	   (especially if the eigenvalue is ill-conditioned); in this case
! 	   INFO is set to size(A,1) + 2 (see INFO below).
!          Note: Select must be present if SDIM is desired.
! SDIM     Optional (output) INTEGER.
!          The number of eigenvalues (after sorting) for which SELECT =
! 	   .TRUE. (If A and B are real, then complex conjugate pairs for
! 	   which SELECT = .TRUE. for either eigenvalue count as 2).
! INFO     Optional (output) INTEGER.
!          = 0: successful exit.
!          < 0: if INFO = -i, the i-th argument had an illegal value.
!          > 0: if INFO = i, and i is
!            <= n: the QZ iteration failed. The matrix pair (A,B) has not
! 	      been reduced to Schur form, but (<alpha(j)>,BETA(j))
! 	      should be correct for j = INFO + 1,..., n.
!            = n+1: another part of the algorithm failed.
!            = n+2: after reordering, roundoff changed values of some
! 	      complex eigenvalues so that leading eigenvalues in the
! 	      Schur form no longer satisfy SELECT = .TRUE. This can be
! 	      caused by ordinary roundoff or underflow due to scaling.
!            = n+3: the reordering failed.
!          If INFO is not present and an error occurs, then the program
!          is terminated with an error message.
!-----------------------------------------------------------------------
!  .. LOCAL PARAMETERS ..
      CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_GGES'
!  .. LOCAL SCALARS ..
      CHARACTER(LEN=1) :: LJOBVSL, LJOBVSR, LSORT
      INTEGER, SAVE :: LWORK = 0
      INTEGER :: N, LINFO, LDA, LDB, ISTAT, S1VSL, S2VSL, S1VSR, S2VSR, &
     &  SALPHA, SBETA
      INTEGER :: LSDIM
!  .. LOCAL ARRAYS ..
      COMPLEX(WP), TARGET :: LLVSL(1,1), LLVSR(1,1), WORKMIN(1)
      COMPLEX(WP), POINTER :: WORK(:)
        REAL(WP), POINTER :: RWORK(:)
      LOGICAL, POINTER :: BWORK(:)
      LOGICAL, TARGET :: LLBWORK(1)
!  .. INTRINSIC FUNCTIONS ..
      INTRINSIC MAX, PRESENT, SIZE
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0; N = SIZE(A,1); LDA = MAX(1,N); LDB = MAX(1,SIZE(B,1))
   SALPHA = SIZE(ALPHA)
   IF (PRESENT (SELECT)) THEN
      LSORT = 'S'; ELSE ; LSORT = 'N'; ENDIF
   SBETA = SIZE(BETA)
   IF( PRESENT(VSL) )THEN; S1VSL = SIZE(VSL,1); S2VSL = SIZE(VSL,2); LJOBVSL = 'V'
   ELSE; S1VSL = 1; S2VSL = 1; LJOBVSL = 'N'; END IF
   IF( PRESENT(VSR) )THEN; S1VSR = SIZE(VSR,1); S2VSR = SIZE(VSR,2); LJOBVSR = 'V'
   ELSE; S1VSR = 1; S2VSR = 1; LJOBVSR = 'N'; END IF
!  .. TEST THE ARGUMENTS
   IF( N < 0 .OR. SIZE(A,2) /= N )THEN; LINFO = -1
      ELSE IF( SIZE(B,1) /= N .OR. SIZE(B,2) /= N )THEN; LINFO = -2
       ELSE IF( SALPHA /= N )THEN; LINFO = -3
       ELSE IF( SBETA /= N )THEN; LINFO = -4
       ELSE IF( PRESENT(VSL) .AND. ( S1VSL /= N .OR. S2VSL /= N) )THEN; LINFO = -5
       ELSE IF( PRESENT(VSR) .AND. ( S1VSR /= N .OR. S2VSR /= N ) )THEN; LINFO = -6

       ELSE IF( N >= 0 )THEN
       IF(LSAME(LSORT,'S')) THEN;  ALLOCATE(BWORK(N),STAT=ISTAT)
        IF (ISTAT /= 0) THEN ; LINFO=-100; GOTO 500; ENDIF
       ELSE; BWORK => LLBWORK; END IF

       ALLOCATE(RWORK(8*N), STAT = ISTAT)
       IF (ISTAT /= 0) THEN ; LINFO=-100; GOTO 100; ENDIF

! .. DETERMINE THE WORKSPACE ..
! .. QUERING THE SIZE OF WORKSPACE ..
        LWORK = -1
        IF( PRESENT(VSL) )THEN
	   IF( PRESENT(VSR) )THEN
               CALL GGES_F77( LJOBVSL, LJOBVSR, LSORT, SELECT, N, A, LDA, B, LDB, &
&                  LSDIM, ALPHA, BETA, VSL, MAX(1,S1VSL), VSR, MAX(1,S1VSR), &
&                  WORKMIN, LWORK, RWORK, BWORK,  LINFO )
           ELSE
	       CALL GGES_F77( LJOBVSL, LJOBVSR, LSORT, SELECT, N, A, LDA, B, LDB, &
&                  LSDIM, ALPHA, BETA, VSL, MAX(1,S1VSL), LLVSR, MAX(1,S1VSR), &
&                  WORKMIN, LWORK, RWORK, BWORK,  LINFO )
           ENDIF
	 ELSE
           IF( PRESENT(VSR) )THEN
               CALL GGES_F77( LJOBVSL, LJOBVSR, LSORT, SELECT, N, A, LDA, B, LDB, &
&                  LSDIM, ALPHA, BETA, LLVSL, MAX(1,S1VSL), VSR, MAX(1,S1VSR), &
&                  WORKMIN, LWORK, RWORK, BWORK,  LINFO )
           ELSE
	       CALL GGES_F77( LJOBVSL, LJOBVSR, LSORT, SELECT, N, A, LDA, B, LDB, &
&                  LSDIM, ALPHA, BETA, LLVSL, MAX(1,S1VSL), LLVSR, MAX(1,S1VSR), &
&                  WORKMIN, LWORK, RWORK, BWORK,  LINFO )
           ENDIF
	 ENDIF
        LWORK = WORKMIN(1)

        ALLOCATE(WORK(LWORK), STAT=ISTAT)
        IF (ISTAT /= 0) THEN ; LINFO=-100; GOTO 400; ENDIF

        IF( PRESENT(VSL) )THEN
	  IF( PRESENT(VSR) )THEN
              CALL GGES_F77( LJOBVSL, LJOBVSR, LSORT, SELECT, N, A, LDA, B, LDB, &
&                 LSDIM, ALPHA, BETA, VSL, MAX(1,S1VSL), VSR, MAX(1,S1VSR), &
&                 WORK, LWORK, RWORK, BWORK,  LINFO )
          ELSE
	      CALL GGES_F77( LJOBVSL, LJOBVSR, LSORT, SELECT, N, A, LDA, B, LDB, &
&                 LSDIM, ALPHA, BETA, VSL, MAX(1,S1VSL), LLVSR, MAX(1,S1VSR), &
&                 WORK, LWORK, RWORK, BWORK,  LINFO )
          ENDIF
	ELSE
	  IF( PRESENT(VSR) )THEN
              CALL GGES_F77( LJOBVSL, LJOBVSR, LSORT, SELECT, N, A, LDA, B, LDB, &
&                 LSDIM, ALPHA, BETA, LLVSL, MAX(1,S1VSL), VSR, MAX(1,S1VSR), &
&                 WORK, LWORK, RWORK, BWORK,  LINFO )
          ELSE
	      CALL GGES_F77( LJOBVSL, LJOBVSR, LSORT, SELECT, N, A, LDA, B, LDB, &
&                 LSDIM, ALPHA, BETA, LLVSL, MAX(1,S1VSL), LLVSR, MAX(1,S1VSR), &
&                 WORK, LWORK, RWORK, BWORK,  LINFO )
          ENDIF
	ENDIF
          IF (PRESENT(SDIM)) SDIM = LSDIM

          DEALLOCATE(WORK)
400       DEALLOCATE(RWORK)
100       IF(LSAME(LSORT,'S')) DEALLOCATE(BWORK)
        ENDIF
500     CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
END SUBROUTINE ZGGES_F95


program problem97
  implicit none
  integer            :: i
  integer*16         :: number,modulus
  integer, parameter :: power=7830457

  modulus=1_16
  do i=1,10
     modulus=modulus*10
  end do

  number=28433_16
  do i=1,power
     number=number*2
     number=mod(number,modulus)
  end do
  number=number+1

  print *,number

end program problem97


c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c        ACKNOWLEDGE THE USE OF THIS PACKAGE
c         WHEN YOU PUBLISH YOUR RESULTS !!!
c>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
c
c************ Sample main program #11 *****************
c  1d Heisenberg antiferromagnet with 8 spins
c    Eigenvalues and an eigenvector by diag
c*************************************************
      parameter (n=14,idim=3432,ibond=n)
      implicit real*8 (a-h,o-z)
      dimension E(4)
      dimension elemnt(idim,idim)
      dimension list1(idim),list2(2,0:2**15)
      dimension bondwt(ibond),ipair(2*ibond),zrtio(ibond)
      dimension npair(2),sxx(1),szz(1)
      dimension wk(idim,8),iwk(idim),v(idim)
c
      data bondwt/ibond*-1.0d0/
      data zrtio/ibond*1.0d0/
      data ipair/1,2, 2,3, 3,4, 4,5, 5,6, 6,7, 7,8, 8,9,
     &     9,10, 10,11, 11,12, 12,13, 13,14, 14,1/
c
      call clock(t1)
      call sz(n,idim,0.0d0,list1,list2)
c- You may alternatively use szdy or sztn for faster processing -
c      call szdy(n,idim,0.0d0,list1,list2)
c  or
c      call sztn(n,idim,0.0d0,list1,list2)
c------------------------------------------------------------
      call elm3(n,idim,ipair,bondwt,zrtio,ibond,
     &          elemnt,idim,list1,list2)
c
      call clock(t2)
      eps=1.d-13
      nvec=1
      ne=4
      call diag(elemnt,idim,idim,E,v,ne,nvec,eps,wk,iwk)
      call clock(t3)
      print 100,E
  100 format(/' [Eigenvalues]  '/2x,4f14.8)
c*** Do not forget to call elm3 again before calling check3
      call elm3(n,idim,ipair,bondwt,zrtio,ibond,
     &          elemnt,idim,list1,list2)
      call check3(elemnt,idim,idim,v,wk,Hexpec)
      call clock(t4)
c
      npair(1)=1
      npair(2)=2
      call xcorr(n,idim,npair,1,v,sxx,list1,list2)
      print *,' sxx:',sxx
      call zcorr(n,idim,npair,1,v,szz,list1)
      print *,' szz:',szz
      call clock(t5)
      write(6,'(A,f8.3,A)') 'initialize      ', (t2-t1), ' sec'
      write(6,'(A,f8.3,A)') 'diagonalization ', (t3-t2), ' sec'
      write(6,'(A,f8.3,A)') 'check           ', (t4-t3), ' sec'
      write(6,'(A,f8.3,A)') 'correlation     ', (t5-t4), ' sec'
      end


submodule (stdlib_stats) stdlib_stats_moment_mask

  use, intrinsic:: ieee_arithmetic, only: ieee_value, ieee_quiet_nan
  use stdlib_error, only: error_stop
  use stdlib_optval, only: optval
  implicit none

contains

      module function moment_mask_1_rdp_rdp(x, order, dim, center, mask) result(res)
        real(dp), intent(in) :: x(:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in), optional :: center
        logical, intent(in) :: mask(:)
        real(dp) :: res

        integer :: i
        real(dp) :: n
        real(dp), allocatable :: mean_

        n = real(count(mask, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + merge( (x(i) -&
                  center)**order,&
                    0._dp,&
                    mask(i))
              end do
            else
              allocate(mean_, source = mean(x, 1, mask))
              do i = 1, size(x, 1)
                res = res + merge( (x(i) - mean_)**order,&
                    0._dp,&
                    mask(i))
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_mask_1_rdp_rdp
      module function moment_mask_2_rdp_rdp(x, order, dim, center, mask) result(res)
        real(dp), intent(in) :: x(:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1<dim))
        logical, intent(in) :: mask(:,:)
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim))

        integer :: i
        real(dp) :: n(merge(size(x, 1), size(x, 2), mask=1<dim))
        real(dp), allocatable :: mean_(:)

        n = real(count(mask, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + merge( (x(i, :) -&
                  center)**order,&
                    0._dp,&
                    mask(i, :))
              end do
            else
              allocate(mean_, source = mean(x, 1, mask))
              do i = 1, size(x, 1)
                res = res + merge( (x(i, :) - mean_)**order,&
                    0._dp,&
                    mask(i, :))
              end do
              deallocate(mean_)
            end if
          case(2)
            if (present(center)) then
              do i = 1, size(x, 2)
                res = res + merge( (x(:, i) -&
                  center)**order,&
                    0._dp,&
                    mask(:, i))
              end do
            else
              allocate(mean_, source = mean(x, 2, mask))
              do i = 1, size(x, 2)
                res = res + merge( (x(:, i) - mean_)**order,&
                    0._dp,&
                    mask(:, i))
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_mask_2_rdp_rdp
      module function moment_mask_3_rdp_rdp(x, order, dim, center, mask) result(res)
        real(dp), intent(in) :: x(:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3),&
            & mask=2<dim))
        logical, intent(in) :: mask(:,:,:)
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        integer :: i
        real(dp) :: n(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))
        real(dp), allocatable :: mean_(:,:)

        n = real(count(mask, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + merge( (x(i, :, :) -&
                  center)**order,&
                    0._dp,&
                    mask(i, :, :))
              end do
            else
              allocate(mean_, source = mean(x, 1, mask))
              do i = 1, size(x, 1)
                res = res + merge( (x(i, :, :) - mean_)**order,&
                    0._dp,&
                    mask(i, :, :))
              end do
              deallocate(mean_)
            end if
          case(2)
            if (present(center)) then
              do i = 1, size(x, 2)
                res = res + merge( (x(:, i, :) -&
                  center)**order,&
                    0._dp,&
                    mask(:, i, :))
              end do
            else
              allocate(mean_, source = mean(x, 2, mask))
              do i = 1, size(x, 2)
                res = res + merge( (x(:, i, :) - mean_)**order,&
                    0._dp,&
                    mask(:, i, :))
              end do
              deallocate(mean_)
            end if
          case(3)
            if (present(center)) then
              do i = 1, size(x, 3)
                res = res + merge( (x(:, :, i) -&
                  center)**order,&
                    0._dp,&
                    mask(:, :, i))
              end do
            else
              allocate(mean_, source = mean(x, 3, mask))
              do i = 1, size(x, 3)
                res = res + merge( (x(:, :, i) - mean_)**order,&
                    0._dp,&
                    mask(:, :, i))
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_mask_3_rdp_rdp
      module function moment_mask_4_rdp_rdp(x, order, dim, center, mask) result(res)
        real(dp), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3),&
            & mask=2<dim), merge(size(x, 3), size(x, 4), mask=3<dim))
        logical, intent(in) :: mask(:,:,:,:)
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        integer :: i
        real(dp) :: n(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))
        real(dp), allocatable :: mean_(:,:,:)

        n = real(count(mask, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + merge( (x(i, :, :, :) -&
                  center)**order,&
                    0._dp,&
                    mask(i, :, :, :))
              end do
            else
              allocate(mean_, source = mean(x, 1, mask))
              do i = 1, size(x, 1)
                res = res + merge( (x(i, :, :, :) - mean_)**order,&
                    0._dp,&
                    mask(i, :, :, :))
              end do
              deallocate(mean_)
            end if
          case(2)
            if (present(center)) then
              do i = 1, size(x, 2)
                res = res + merge( (x(:, i, :, :) -&
                  center)**order,&
                    0._dp,&
                    mask(:, i, :, :))
              end do
            else
              allocate(mean_, source = mean(x, 2, mask))
              do i = 1, size(x, 2)
                res = res + merge( (x(:, i, :, :) - mean_)**order,&
                    0._dp,&
                    mask(:, i, :, :))
              end do
              deallocate(mean_)
            end if
          case(3)
            if (present(center)) then
              do i = 1, size(x, 3)
                res = res + merge( (x(:, :, i, :) -&
                  center)**order,&
                    0._dp,&
                    mask(:, :, i, :))
              end do
            else
              allocate(mean_, source = mean(x, 3, mask))
              do i = 1, size(x, 3)
                res = res + merge( (x(:, :, i, :) - mean_)**order,&
                    0._dp,&
                    mask(:, :, i, :))
              end do
              deallocate(mean_)
            end if
          case(4)
            if (present(center)) then
              do i = 1, size(x, 4)
                res = res + merge( (x(:, :, :, i) -&
                  center)**order,&
                    0._dp,&
                    mask(:, :, :, i))
              end do
            else
              allocate(mean_, source = mean(x, 4, mask))
              do i = 1, size(x, 4)
                res = res + merge( (x(:, :, :, i) - mean_)**order,&
                    0._dp,&
                    mask(:, :, :, i))
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_mask_4_rdp_rdp
      module function moment_mask_1_cdp_cdp(x, order, dim, center, mask) result(res)
        complex(dp), intent(in) :: x(:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        complex(dp), intent(in), optional :: center
        logical, intent(in) :: mask(:)
        complex(dp) :: res

        integer :: i
        real(dp) :: n
        complex(dp), allocatable :: mean_

        n = real(count(mask, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + merge( (x(i) -&
                  center)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(i))
              end do
            else
              allocate(mean_, source = mean(x, 1, mask))
              do i = 1, size(x, 1)
                res = res + merge( (x(i) - mean_)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(i))
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_mask_1_cdp_cdp
      module function moment_mask_2_cdp_cdp(x, order, dim, center, mask) result(res)
        complex(dp), intent(in) :: x(:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        complex(dp), intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1<dim))
        logical, intent(in) :: mask(:,:)
        complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim))

        integer :: i
        real(dp) :: n(merge(size(x, 1), size(x, 2), mask=1<dim))
        complex(dp), allocatable :: mean_(:)

        n = real(count(mask, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + merge( (x(i, :) -&
                  center)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(i, :))
              end do
            else
              allocate(mean_, source = mean(x, 1, mask))
              do i = 1, size(x, 1)
                res = res + merge( (x(i, :) - mean_)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(i, :))
              end do
              deallocate(mean_)
            end if
          case(2)
            if (present(center)) then
              do i = 1, size(x, 2)
                res = res + merge( (x(:, i) -&
                  center)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(:, i))
              end do
            else
              allocate(mean_, source = mean(x, 2, mask))
              do i = 1, size(x, 2)
                res = res + merge( (x(:, i) - mean_)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(:, i))
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_mask_2_cdp_cdp
      module function moment_mask_3_cdp_cdp(x, order, dim, center, mask) result(res)
        complex(dp), intent(in) :: x(:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        complex(dp), intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3),&
            & mask=2<dim))
        logical, intent(in) :: mask(:,:,:)
        complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        integer :: i
        real(dp) :: n(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))
        complex(dp), allocatable :: mean_(:,:)

        n = real(count(mask, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + merge( (x(i, :, :) -&
                  center)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(i, :, :))
              end do
            else
              allocate(mean_, source = mean(x, 1, mask))
              do i = 1, size(x, 1)
                res = res + merge( (x(i, :, :) - mean_)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(i, :, :))
              end do
              deallocate(mean_)
            end if
          case(2)
            if (present(center)) then
              do i = 1, size(x, 2)
                res = res + merge( (x(:, i, :) -&
                  center)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(:, i, :))
              end do
            else
              allocate(mean_, source = mean(x, 2, mask))
              do i = 1, size(x, 2)
                res = res + merge( (x(:, i, :) - mean_)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(:, i, :))
              end do
              deallocate(mean_)
            end if
          case(3)
            if (present(center)) then
              do i = 1, size(x, 3)
                res = res + merge( (x(:, :, i) -&
                  center)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(:, :, i))
              end do
            else
              allocate(mean_, source = mean(x, 3, mask))
              do i = 1, size(x, 3)
                res = res + merge( (x(:, :, i) - mean_)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(:, :, i))
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_mask_3_cdp_cdp
      module function moment_mask_4_cdp_cdp(x, order, dim, center, mask) result(res)
        complex(dp), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        complex(dp), intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3),&
            & mask=2<dim), merge(size(x, 3), size(x, 4), mask=3<dim))
        logical, intent(in) :: mask(:,:,:,:)
        complex(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        integer :: i
        real(dp) :: n(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))
        complex(dp), allocatable :: mean_(:,:,:)

        n = real(count(mask, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + merge( (x(i, :, :, :) -&
                  center)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(i, :, :, :))
              end do
            else
              allocate(mean_, source = mean(x, 1, mask))
              do i = 1, size(x, 1)
                res = res + merge( (x(i, :, :, :) - mean_)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(i, :, :, :))
              end do
              deallocate(mean_)
            end if
          case(2)
            if (present(center)) then
              do i = 1, size(x, 2)
                res = res + merge( (x(:, i, :, :) -&
                  center)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(:, i, :, :))
              end do
            else
              allocate(mean_, source = mean(x, 2, mask))
              do i = 1, size(x, 2)
                res = res + merge( (x(:, i, :, :) - mean_)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(:, i, :, :))
              end do
              deallocate(mean_)
            end if
          case(3)
            if (present(center)) then
              do i = 1, size(x, 3)
                res = res + merge( (x(:, :, i, :) -&
                  center)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(:, :, i, :))
              end do
            else
              allocate(mean_, source = mean(x, 3, mask))
              do i = 1, size(x, 3)
                res = res + merge( (x(:, :, i, :) - mean_)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(:, :, i, :))
              end do
              deallocate(mean_)
            end if
          case(4)
            if (present(center)) then
              do i = 1, size(x, 4)
                res = res + merge( (x(:, :, :, i) -&
                  center)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(:, :, :, i))
              end do
            else
              allocate(mean_, source = mean(x, 4, mask))
              do i = 1, size(x, 4)
                res = res + merge( (x(:, :, :, i) - mean_)**order,&
                    cmplx(0,0,kind=dp),&
                    mask(:, :, :, i))
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_mask_4_cdp_cdp

      module function moment_mask_1_iint32_dp(x, order, dim, center, mask) result(res)
        integer(int32), intent(in) :: x(:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in), optional :: center
        logical, intent(in) :: mask(:)
        real(dp) :: res

        integer :: i
        real(dp) :: n
        real(dp), allocatable :: mean_

        n = real(count(mask, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + merge((real(x(i), dp) -&
                                    center)**order,&
                                    0._dp, mask(i))
              end do
            else
              allocate(mean_, source = mean(x, 1, mask))
              do i = 1, size(x, 1)
                res = res + merge((real(x(i), dp) - mean_)&
                                    **order,&
                                    0._dp, mask(i))
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_mask_1_iint32_dp
      module function moment_mask_2_iint32_dp(x, order, dim, center, mask) result(res)
        integer(int32), intent(in) :: x(:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1<dim))
        logical, intent(in) :: mask(:,:)
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim))

        integer :: i
        real(dp) :: n(merge(size(x, 1), size(x, 2), mask=1<dim))
        real(dp), allocatable :: mean_(:)

        n = real(count(mask, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + merge((real(x(i, :), dp) -&
                                    center)**order,&
                                    0._dp, mask(i, :))
              end do
            else
              allocate(mean_, source = mean(x, 1, mask))
              do i = 1, size(x, 1)
                res = res + merge((real(x(i, :), dp) - mean_)&
                                    **order,&
                                    0._dp, mask(i, :))
              end do
              deallocate(mean_)
            end if
          case(2)
            if (present(center)) then
              do i = 1, size(x, 2)
                res = res + merge((real(x(:, i), dp) -&
                                    center)**order,&
                                    0._dp, mask(:, i))
              end do
            else
              allocate(mean_, source = mean(x, 2, mask))
              do i = 1, size(x, 2)
                res = res + merge((real(x(:, i), dp) - mean_)&
                                    **order,&
                                    0._dp, mask(:, i))
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_mask_2_iint32_dp
      module function moment_mask_3_iint32_dp(x, order, dim, center, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3),&
            & mask=2<dim))
        logical, intent(in) :: mask(:,:,:)
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))

        integer :: i
        real(dp) :: n(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim))
        real(dp), allocatable :: mean_(:,:)

        n = real(count(mask, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + merge((real(x(i, :, :), dp) -&
                                    center)**order,&
                                    0._dp, mask(i, :, :))
              end do
            else
              allocate(mean_, source = mean(x, 1, mask))
              do i = 1, size(x, 1)
                res = res + merge((real(x(i, :, :), dp) - mean_)&
                                    **order,&
                                    0._dp, mask(i, :, :))
              end do
              deallocate(mean_)
            end if
          case(2)
            if (present(center)) then
              do i = 1, size(x, 2)
                res = res + merge((real(x(:, i, :), dp) -&
                                    center)**order,&
                                    0._dp, mask(:, i, :))
              end do
            else
              allocate(mean_, source = mean(x, 2, mask))
              do i = 1, size(x, 2)
                res = res + merge((real(x(:, i, :), dp) - mean_)&
                                    **order,&
                                    0._dp, mask(:, i, :))
              end do
              deallocate(mean_)
            end if
          case(3)
            if (present(center)) then
              do i = 1, size(x, 3)
                res = res + merge((real(x(:, :, i), dp) -&
                                    center)**order,&
                                    0._dp, mask(:, :, i))
              end do
            else
              allocate(mean_, source = mean(x, 3, mask))
              do i = 1, size(x, 3)
                res = res + merge((real(x(:, :, i), dp) - mean_)&
                                    **order,&
                                    0._dp, mask(:, :, i))
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_mask_3_iint32_dp
      module function moment_mask_4_iint32_dp(x, order, dim, center, mask) result(res)
        integer(int32), intent(in) :: x(:,:,:,:)
        integer, intent(in) :: order
        integer, intent(in) :: dim
        real(dp), intent(in), optional :: center(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3),&
            & mask=2<dim), merge(size(x, 3), size(x, 4), mask=3<dim))
        logical, intent(in) :: mask(:,:,:,:)
        real(dp) :: res(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))

        integer :: i
        real(dp) :: n(merge(size(x, 1), size(x, 2), mask=1<dim), merge(size(x, 2), size(x, 3), mask=2<dim), merge(size(x, 3),&
            & size(x, 4), mask=3<dim))
        real(dp), allocatable :: mean_(:,:,:)

        n = real(count(mask, dim), dp)

        res = 0
        select case(dim)
          case(1)
            if (present(center)) then
              do i = 1, size(x, 1)
                res = res + merge((real(x(i, :, :, :), dp) -&
                                    center)**order,&
                                    0._dp, mask(i, :, :, :))
              end do
            else
              allocate(mean_, source = mean(x, 1, mask))
              do i = 1, size(x, 1)
                res = res + merge((real(x(i, :, :, :), dp) - mean_)&
                                    **order,&
                                    0._dp, mask(i, :, :, :))
              end do
              deallocate(mean_)
            end if
          case(2)
            if (present(center)) then
              do i = 1, size(x, 2)
                res = res + merge((real(x(:, i, :, :), dp) -&
                                    center)**order,&
                                    0._dp, mask(:, i, :, :))
              end do
            else
              allocate(mean_, source = mean(x, 2, mask))
              do i = 1, size(x, 2)
                res = res + merge((real(x(:, i, :, :), dp) - mean_)&
                                    **order,&
                                    0._dp, mask(:, i, :, :))
              end do
              deallocate(mean_)
            end if
          case(3)
            if (present(center)) then
              do i = 1, size(x, 3)
                res = res + merge((real(x(:, :, i, :), dp) -&
                                    center)**order,&
                                    0._dp, mask(:, :, i, :))
              end do
            else
              allocate(mean_, source = mean(x, 3, mask))
              do i = 1, size(x, 3)
                res = res + merge((real(x(:, :, i, :), dp) - mean_)&
                                    **order,&
                                    0._dp, mask(:, :, i, :))
              end do
              deallocate(mean_)
            end if
          case(4)
            if (present(center)) then
              do i = 1, size(x, 4)
                res = res + merge((real(x(:, :, :, i), dp) -&
                                    center)**order,&
                                    0._dp, mask(:, :, :, i))
              end do
            else
              allocate(mean_, source = mean(x, 4, mask))
              do i = 1, size(x, 4)
                res = res + merge((real(x(:, :, :, i), dp) - mean_)&
                                    **order,&
                                    0._dp, mask(:, :, :, i))
              end do
              deallocate(mean_)
            end if
          case default
            call error_stop("ERROR (moment): wrong dimension")
        end select
        res = res / n

      end function moment_mask_4_iint32_dp

end submodule


!< Jiang-Shu and Gerolymos-Senechal-Vallet weights.
module wenoof_weights_int_js
!< Jiang-Shu and Gerolymos-Senechal-Vallet weights.
!<
!< @note The provided WENO weights implements the weights defined in *Efficient Implementation of Weighted ENO
!< Schemes*, Guang-Shan Jiang, Chi-Wang Shu, JCP, 1996, vol. 126, pp. 202--228, doi:10.1006/jcph.1996.0130 and
!< *Very-high-order weno schemes*, G. A. Gerolymos, D. Senechal, I. Vallet, JCP, 2009, vol. 228, pp. 8481-8524,
!< doi:10.1016/j.jcp.2009.07.039

use penf, only : I_P, R_P, str
use wenoof_alpha_factory,  only : alpha_factory
use wenoof_alpha_object, only : alpha_object, alpha_object_constructor
use wenoof_base_object, only : base_object, base_object_constructor
use wenoof_beta_factory, only : beta_factory
use wenoof_beta_object, only : beta_object, beta_object_constructor
use wenoof_kappa_factory, only : kappa_factory
use wenoof_kappa_int_js, only : kappa_int_js
use wenoof_kappa_object, only : kappa_object, kappa_object_constructor
use wenoof_weights_object, only : weights_object, weights_object_constructor

implicit none
private
public :: weights_int_js
public :: weights_int_js_constructor

type, extends(weights_object_constructor) :: weights_int_js_constructor
  !< Jiang-Shu and Gerolymos-Senechal-Vallet optimal weights object constructor.
  class(alpha_object_constructor), allocatable :: alpha_constructor !< Alpha coefficients (non linear weights) constructor.
  class(beta_object_constructor),  allocatable :: beta_constructor  !< Beta coefficients (smoothness indicators) constructor.
  class(kappa_object_constructor), allocatable :: kappa_constructor !< kappa coefficients (optimal, linear weights) constructor.
  contains
    ! public deferred methods
    procedure, pass(lhs) :: constr_assign_constr !< `=` operator.
endtype weights_int_js_constructor

type, extends(weights_object):: weights_int_js
  !< Jiang-Shu and Gerolymos-Senechal-Vallet weights object.
  !<
  !< @note The provided WENO weights implements the weights defined in *Efficient Implementation of Weighted ENO
  !< Schemes*, Guang-Shan Jiang, Chi-Wang Shu, JCP, 1996, vol. 126, pp. 202--228, doi:10.1006/jcph.1996.0130 and
  !< *Very-high-order weno schemes*, G. A. Gerolymos, D. Senechal, I. Vallet, JCP, 2009, vol. 228, pp. 8481-8524,
  !< doi:10.1016/j.jcp.2009.07.039
  class(alpha_object), allocatable :: alpha !< Alpha coefficients (non linear weights).
  class(beta_object),  allocatable :: beta  !< Beta coefficients (smoothness indicators).
  class(kappa_object), allocatable :: kappa !< kappa coefficients (optimal, linear weights).
  contains
    ! deferred public methods
    procedure, pass(self) :: create                    !< Create weights.
    procedure, pass(self) :: compute_int               !< Compute weights (interpolate).
    procedure, pass(self) :: compute_rec               !< Compute weights (reconstruct).
    procedure, pass(self) :: description               !< Return object string-description.
    procedure, pass(self) :: destroy                   !< Destroy weights.
    procedure, pass(self) :: smoothness_indicators_int !< Return smoothness indicators (interpolate).
    procedure, pass(self) :: smoothness_indicators_rec !< Return smoothness indicators (reconstrcut).
    procedure, pass(lhs)  :: object_assign_object      !< `=` operator.
endtype weights_int_js

contains
  ! constructor

  ! deferred public methods
  subroutine constr_assign_constr(lhs, rhs)
  !< `=` operator.
  class(weights_int_js_constructor), intent(inout) :: lhs !< Left hand side.
  class(base_object_constructor),  intent(in)    :: rhs !< Right hand side.

  call lhs%assign_(rhs=rhs)
  select type(rhs)
  type is(weights_int_js_constructor)
     if (allocated(rhs%alpha_constructor)) then
        if (.not.allocated(lhs%alpha_constructor)) allocate(lhs%alpha_constructor, mold=rhs%alpha_constructor)
           lhs%alpha_constructor = rhs%alpha_constructor
     else
        if (allocated(lhs%alpha_constructor)) deallocate(lhs%alpha_constructor)
     endif
     if (allocated(rhs%beta_constructor)) then
        if (.not.allocated(lhs%beta_constructor)) allocate(lhs%beta_constructor, mold=rhs%beta_constructor)
           lhs%beta_constructor = rhs%beta_constructor
     else
        if (allocated(lhs%beta_constructor)) deallocate(lhs%beta_constructor)
     endif
     if (allocated(rhs%kappa_constructor)) then
        if (.not.allocated(lhs%kappa_constructor)) allocate(lhs%kappa_constructor, mold=rhs%kappa_constructor)
           lhs%kappa_constructor = rhs%kappa_constructor
     else
        if (allocated(lhs%kappa_constructor)) deallocate(lhs%kappa_constructor)
     endif
  endselect
  endsubroutine constr_assign_constr

  ! deferred public methods
  subroutine create(self, constructor)
  !< Create reconstructor.
  class(weights_int_js),          intent(inout) :: self        !< Weights.
  class(base_object_constructor), intent(in)    :: constructor !< Constructor.
  type(alpha_factory)                           :: a_factory   !< Alpha factory.
  type(beta_factory)                            :: b_factory   !< Beta factory.
  type(kappa_factory)                           :: k_factory   !< Kappa factory.

  call self%destroy
  call self%create_(constructor=constructor)
  select type(constructor)
  type is(weights_int_js_constructor)
    associate(alpha_constructor=>constructor%alpha_constructor, &
              beta_constructor=>constructor%beta_constructor,   &
              kappa_constructor=>constructor%kappa_constructor)
      call a_factory%create(constructor=alpha_constructor, object=self%alpha)
      call b_factory%create(constructor=beta_constructor, object=self%beta)
      call k_factory%create(constructor=kappa_constructor, object=self%kappa)
    endassociate
  endselect
  endsubroutine create

  pure subroutine compute_int(self, stencil, values)
  !< Compute weights.
  class(weights_int_js), intent(in)  :: self               !< Weights.
  real(R_P),             intent(in)  :: stencil(1-self%S:) !< Stencil used for the interpolation, [1-S:-1+S].
  real(R_P),             intent(out) :: values(0:)         !< Weights values.
  real(R_P)                          :: alpha(0:self%S-1)  !< Aplha values.
  real(R_P)                          :: beta(0:self%S-1)   !< Beta values.
  real(R_P)                          :: alpha_sum          !< Sum of aplha values.
  integer(I_P)                       :: s                  !< Counters.

  call self%beta%compute(stencil=stencil, values=beta)
  select type(kappa => self%kappa)
  class is(kappa_int_js)
    call self%alpha%compute(beta=beta, kappa=kappa%values, values=alpha)
  endselect
  alpha_sum = sum(alpha)
  do s=0, self%S - 1 ! stencils loop
    values(s) = alpha(s) / alpha_sum
  enddo
  endsubroutine compute_int

  pure subroutine compute_rec(self, stencil, values)
  !< Compute weights.
  class(weights_int_js), intent(in)  :: self                  !< Weights.
  real(R_P),             intent(in)  :: stencil(1:,1-self%S:) !< Stencil used for the interpolation, [1:2, 1-S:-1+S].
  real(R_P),             intent(out) :: values(1:,0:)         !< Weights values of stencil interpolations.
  ! empty procedure
  endsubroutine compute_rec

  pure function description(self, prefix) result(string)
  !< Return object string-descripition.
  class(weights_int_js), intent(in)           :: self             !< Weights.
  character(len=*),      intent(in), optional :: prefix           !< Prefixing string.
  character(len=:), allocatable               :: string           !< String-description.
  character(len=:), allocatable               :: prefix_          !< Prefixing string, local variable.
  character(len=1), parameter                 :: NL=new_line('a') !< New line char.

  prefix_ = '' ; if (present(prefix)) prefix_ = prefix
  string = prefix_//'Jiang-Shu weights object for interpolation:'//NL
  string = string//prefix_//'  - S   = '//trim(str(self%S))//NL
  string = string//prefix_//self%alpha%description(prefix=prefix_//'  ')
  endfunction description

  elemental subroutine destroy(self)
  !< Destroy weights.
  class(weights_int_js), intent(inout) :: self !< Weights.

  call self%destroy_
  if (allocated(self%alpha)) deallocate(self%alpha)
  if (allocated(self%beta)) deallocate(self%beta)
  if (allocated(self%kappa)) deallocate(self%kappa)
  endsubroutine destroy

  pure subroutine smoothness_indicators_int(self, si)
  !< Return smoothness indicators (interpolate).
  class(weights_int_js),  intent(in)  :: self  !< Weights.
  real(R_P),              intent(out) :: si(:) !< Smoothness indicators.
  ! TODO implement this
  endsubroutine smoothness_indicators_int

  pure subroutine smoothness_indicators_rec(self, si)
  !< Return smoothness indicators (reconstruct).
  class(weights_int_js),  intent(in)  :: self    !< Weights.
  real(R_P),              intent(out) :: si(:,:) !< Smoothness indicators.
  ! empty procedure
  endsubroutine smoothness_indicators_rec

  pure subroutine object_assign_object(lhs, rhs)
  !< `=` operator.
  class(weights_int_js), intent(inout) :: lhs !< Left hand side.
  class(base_object),    intent(in)    :: rhs !< Right hand side.

  call lhs%assign_(rhs=rhs)
  select type(rhs)
  type is(weights_int_js)
     if (allocated(rhs%alpha)) then
        if (.not.allocated(lhs%alpha)) allocate(lhs%alpha, mold=rhs%alpha)
        lhs%alpha = rhs%alpha
     else
        if (allocated(lhs%alpha)) deallocate(lhs%alpha)
     endif
     if (allocated(rhs%beta)) then
        if (.not.allocated(lhs%beta)) allocate(lhs%beta, mold=rhs%beta)
        lhs%beta = rhs%beta
     else
        if (allocated(lhs%beta)) deallocate(lhs%beta)
     endif
     if (allocated(rhs%kappa)) then
        if (.not.allocated(lhs%kappa)) allocate(lhs%kappa, mold=rhs%kappa)
        lhs%kappa = rhs%kappa
     else
        if (allocated(lhs%kappa)) deallocate(lhs%kappa)
     endif
  endselect
  endsubroutine object_assign_object
endmodule wenoof_weights_int_js


      SUBROUTINE cdfbet(which,p,q,x,y,a,b,status,bound)
C**********************************************************************
C
C      SUBROUTINE CDFBET( WHICH, P, Q, X, Y, A, B, STATUS, BOUND )
C               Cumulative Distribution Function
C                         BETa Distribution
C
C
C                              Function
C
C
C     Calculates any one parameter of the beta distribution given
C     values for the others.
C
C
C                              Arguments
C
C
C     WHICH --> Integer indicating which of the next four argument
C               values is to be calculated from the others.
C               Legal range: 1..4
C               iwhich = 1 : Calculate P and Q from X,Y,A and B
C               iwhich = 2 : Calculate X and Y from P,Q,A and B
C               iwhich = 3 : Calculate A from P,Q,X,Y and B
C               iwhich = 4 : Calculate B from P,Q,X,Y and A
C
C                    INTEGER WHICH
C
C     P <--> The integral from 0 to X of the chi-square
C            distribution.
C            Input range: [0, 1].
C                    DOUBLE PRECISION P
C
C     Q <--> 1-P.
C            Input range: [0, 1].
C            P + Q = 1.0.
C                    DOUBLE PRECISION Q
C
C     X <--> Upper limit of integration of beta density.
C            Input range: [0,1].
C            Search range: [0,1]
C                    DOUBLE PRECISION X
C
C     Y <--> 1-X.
C            Input range: [0,1].
C            Search range: [0,1]
C            X + Y = 1.0.
C                    DOUBLE PRECISION Y
C
C     A <--> The first parameter of the beta density.
C            Input range: (0, +infinity).
C            Search range: [1D-100,1D100]
C                    DOUBLE PRECISION A
C
C     B <--> The second parameter of the beta density.
C            Input range: (0, +infinity).
C            Search range: [1D-100,1D100]
C                    DOUBLE PRECISION B
C
C     STATUS <-- 0 if calculation completed correctly
C               -I if input parameter number I is out of range
C                1 if answer appears to be lower than lowest
C                  search bound
C                2 if answer appears to be higher than greatest
C                  search bound
C                3 if P + Q .ne. 1
C                4 if X + Y .ne. 1
C                    INTEGER STATUS
C
C     BOUND <-- Undefined if STATUS is 0
C
C               Bound exceeded by parameter number I if STATUS
C               is negative.
C
C               Lower search bound if STATUS is 1.
C
C               Upper search bound if STATUS is 2.
C
C
C                              Method
C
C
C     Cumulative distribution function  (P)  is calculated directly by
C     code associated with the following reference.
C
C     DiDinato, A. R. and Morris,  A.   H.  Algorithm 708: Significant
C     Digit Computation of the Incomplete  Beta  Function Ratios.  ACM
C     Trans. Math.  Softw. 18 (1993), 360-373.
C
C     Computation of other parameters involve a seach for a value that
C     produces  the desired  value  of P.   The search relies  on  the
C     monotinicity of P with the other parameter.
C
C
C                              Note
C
C
C     The beta density is proportional to
C               t^(A-1) * (1-t)^(B-1)
C
C**********************************************************************
C     .. Parameters ..
      DOUBLE PRECISION tol
      PARAMETER (tol=1.0D-8)
      DOUBLE PRECISION atol
      PARAMETER (atol=1.0D-50)
      DOUBLE PRECISION zero,inf
      PARAMETER (zero=1.0D-100,inf=1.0D100)
      DOUBLE PRECISION one
      PARAMETER (one=1.0D0)
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,b,bound,p,q,x,y
      INTEGER status,which
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION ccum,cum,fx,pq,xhi,xlo,xy
      LOGICAL qhi,qleft,qporq
C     ..
C     .. External Functions ..
      DOUBLE PRECISION spmpar
      EXTERNAL spmpar
C     ..
C     .. External Subroutines ..
      EXTERNAL cumbet,dinvr,dstinv,dstzr,dzror
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs
C     ..
      IF (.NOT. ((which.LT.1).OR. (which.GT.4))) GO TO 30
      IF (.NOT. (which.LT.1)) GO TO 10
      bound = 1.0D0
      GO TO 20

   10 bound = 4.0D0
   20 status = -1
      RETURN

   30 IF (which.EQ.1) GO TO 70
      IF (.NOT. ((p.LT.0.0D0).OR. (p.GT.1.0D0))) GO TO 60
      IF (.NOT. (p.LT.0.0D0)) GO TO 40
      bound = 0.0D0
      GO TO 50

   40 bound = 1.0D0
   50 status = -2
      RETURN

   60 CONTINUE
   70 IF (which.EQ.1) GO TO 110
      IF (.NOT. ((q.LT.0.0D0).OR. (q.GT.1.0D0))) GO TO 100
      IF (.NOT. (q.LT.0.0D0)) GO TO 80
      bound = 0.0D0
      GO TO 90

   80 bound = 1.0D0
   90 status = -3
      RETURN

  100 CONTINUE
  110 IF (which.EQ.2) GO TO 150
      IF (.NOT. ((x.LT.0.0D0).OR. (x.GT.1.0D0))) GO TO 140
      IF (.NOT. (x.LT.0.0D0)) GO TO 120
      bound = 0.0D0
      GO TO 130

  120 bound = 1.0D0
  130 status = -4
      RETURN

  140 CONTINUE
  150 IF (which.EQ.2) GO TO 190
      IF (.NOT. ((y.LT.0.0D0).OR. (y.GT.1.0D0))) GO TO 180
      IF (.NOT. (y.LT.0.0D0)) GO TO 160
      bound = 0.0D0
      GO TO 170

  160 bound = 1.0D0
  170 status = -5
      RETURN

  180 CONTINUE
  190 IF (which.EQ.3) GO TO 210
      IF (.NOT. (a.LE.0.0D0)) GO TO 200
      bound = 0.0D0
      status = -6
      RETURN

  200 CONTINUE
  210 IF (which.EQ.4) GO TO 230
      IF (.NOT. (b.LE.0.0D0)) GO TO 220
      bound = 0.0D0
      status = -7
      RETURN

  220 CONTINUE
  230 IF (which.EQ.1) GO TO 270
      pq = p + q
      IF (.NOT. (abs(((pq)-0.5D0)-0.5D0).GT.
     +    (3.0D0*spmpar(1)))) GO TO 260
      IF (.NOT. (pq.LT.0.0D0)) GO TO 240
      bound = 0.0D0
      GO TO 250

  240 bound = 1.0D0
  250 status = 3
      RETURN

  260 CONTINUE
  270 IF (which.EQ.2) GO TO 310
      xy = x + y
      IF (.NOT. (abs(((xy)-0.5D0)-0.5D0).GT.
     +    (3.0D0*spmpar(1)))) GO TO 300
      IF (.NOT. (xy.LT.0.0D0)) GO TO 280
      bound = 0.0D0
      GO TO 290

  280 bound = 1.0D0
  290 status = 4
      RETURN

  300 CONTINUE
  310 IF (.NOT. (which.EQ.1)) qporq = p .LE. q
      IF ((1).EQ. (which)) THEN
          CALL cumbet(x,y,a,b,p,q)
          status = 0

      ELSE IF ((2).EQ. (which)) THEN
          CALL dstzr(0.0D0,1.0D0,atol,tol)
          IF (.NOT. (qporq)) GO TO 340
          status = 0
          CALL dzror(status,x,fx,xlo,xhi,qleft,qhi)
          y = one - x
  320     IF (.NOT. (status.EQ.1)) GO TO 330
          CALL cumbet(x,y,a,b,cum,ccum)
          fx = cum - p
          CALL dzror(status,x,fx,xlo,xhi,qleft,qhi)
          y = one - x
          GO TO 320

  330     GO TO 370

  340     status = 0
          CALL dzror(status,y,fx,xlo,xhi,qleft,qhi)
          x = one - y
  350     IF (.NOT. (status.EQ.1)) GO TO 360
          CALL cumbet(x,y,a,b,cum,ccum)
          fx = ccum - q
          CALL dzror(status,y,fx,xlo,xhi,qleft,qhi)
          x = one - y
          GO TO 350

  360     CONTINUE
  370     IF (.NOT. (status.EQ.-1)) GO TO 400
          IF (.NOT. (qleft)) GO TO 380
          status = 1
          bound = 0.0D0
          GO TO 390

  380     status = 2
          bound = 1.0D0
  390     CONTINUE
  400     CONTINUE

      ELSE IF ((3).EQ. (which)) THEN
          a = 5.0D0
          CALL dstinv(zero,inf,0.5D0,0.5D0,5.0D0,atol,tol)
          status = 0
          CALL dinvr(status,a,fx,qleft,qhi)
  410     IF (.NOT. (status.EQ.1)) GO TO 440
          CALL cumbet(x,y,a,b,cum,ccum)
          IF (.NOT. (qporq)) GO TO 420
          fx = cum - p
          GO TO 430

  420     fx = ccum - q
  430     CALL dinvr(status,a,fx,qleft,qhi)
          GO TO 410

  440     IF (.NOT. (status.EQ.-1)) GO TO 470
          IF (.NOT. (qleft)) GO TO 450
          status = 1
          bound = zero
          GO TO 460

  450     status = 2
          bound = inf
  460     CONTINUE
  470     CONTINUE

      ELSE IF ((4).EQ. (which)) THEN
          b = 5.0D0
          CALL dstinv(zero,inf,0.5D0,0.5D0,5.0D0,atol,tol)
          status = 0
          CALL dinvr(status,b,fx,qleft,qhi)
  480     IF (.NOT. (status.EQ.1)) GO TO 510
          CALL cumbet(x,y,a,b,cum,ccum)
          IF (.NOT. (qporq)) GO TO 490
          fx = cum - p
          GO TO 500

  490     fx = ccum - q
  500     CALL dinvr(status,b,fx,qleft,qhi)
          GO TO 480

  510     IF (.NOT. (status.EQ.-1)) GO TO 540
          IF (.NOT. (qleft)) GO TO 520
          status = 1
          bound = zero
          GO TO 530

  520     status = 2
          bound = inf
  530     CONTINUE
  540 END IF

      RETURN

      END


subroutine ode ( f, neqn, y, t, tout, relerr, abserr, iflag, work, iwork )

!*****************************************************************************80
!
!! ODE is the user interface to an ordinary differential equation solver.
!
!  Discussion:
!
!    ODE integrates a system of NEQN first order ordinary differential
!    equations of the form:
!      dY(i)/dT = F(T,Y(1),Y(2),...,Y(NEQN))
!      Y(i) given at T.
!    The subroutine integrates from T to TOUT.  On return, the
!    parameters in the call list are set for continuing the integration.
!    The user has only to define a new value TOUT and call ODE again.
!
!    The differential equations are actually solved by a suite of codes
!    DE, STEP, and INTRP.  ODE allocates virtual storage in the
!    arrays WORK and IWORK and calls DE.  DE is a supervisor which
!    directs the solution.  It calls the routines STEP and INTRP
!    to advance the integration and to interpolate at output points.
!
!    STEP uses a modified divided difference form of the Adams PECE
!    formulas and local extrapolation.  It adjusts the order and step
!    size to control the local error per unit step in a generalized
!    sense.  Normally each call to STEP advances the solution one step
!    in the direction of TOUT.  For reasons of efficiency, DE integrates
!    beyond TOUT internally, though never beyond T+10*(TOUT-T), and
!    calls INTRP to interpolate the solution at TOUT.  An option is
!    provided to stop the integration at TOUT but it should be used
!    only if it is impossible to continue the integration beyond TOUT.
!
!    On the first call to ODE, the user must provide storage in the calling
!    program for the arrays in the call list,
!      Y(NEQN), WORK(100+21*NEQN), IWORK(5),
!    declare F in an external statement, supply the double precision
!      SUBROUTINE F ( T, Y, YP )
!    to evaluate dy(i)/dt = yp(i) = f(t,y(1),y(2),...,y(neqn))
!    and initialize the parameters:
!    * NEQN, the number of equations to be integrated;
!    * Y(1:NEQN), the vector of initial conditions;
!    * T, the starting point of integration;
!    * TOUT, the point at which a solution is desired;
!    * RELERR, ABSERR, the relative and absolute local error tolerances;
!    * IFLAG, an indicator to initialize the code.  Normal input
!      is +1.  The user should set IFLAG = -1 only if it is
!      impossible to continue the integration beyond TOUT.
!    All parameters except F, NEQN and TOUT may be altered by the
!    code on output, and so must be variables in the calling program.
!
!    On normal return from ODE, IFLAG is 2, indicating that T has been
!    set to TOUT, and Y has been set to the approximate solution at TOUT.
!
!    If IFLAG is 3, then the program noticed that RELERR or ABSERR was
!    too small; the output values of these variables are more appropriate,
!    and integration can be resumed by setting IFLAG to 1.
!
!    IFLAG is -2 if the user input IFLAG = -1, and the code was able to
!    reach TOUT exactly.  In that case, the output value of T is TOUT,
!    and the output value of Y is the solution at TOUT, which was computed
!    directly, and not by interpolation.
!
!    Other values of IFLAG generally indicate an error.
!
!    Normally, it is desirable to compute many points along the solution
!    curve.  After the first successful step, more steps may be taken
!    simply by updating the value of TOUT and calling ODE again.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    02 August 2009
!
!  Author:
!
!    Original FORTRAN77 version by Lawrence Shampine, Marilyn Gordon.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Lawrence Shampine, Marilyn Gordon,
!    Computer Solution of Ordinary Differential Equations:
!    The Initial Value Problem,
!    Freeman, 1975,
!    ISBN: 0716704617,
!    LC: QA372.S416.
!
!  Parameters:
!
!    Input, external F, the name of a user-supplied routine of the form
!      subroutine f ( t, y, yp )
!      real ( kind = 8 ) t
!      real ( kind = 8 ) y(neqn)
!      real ( kind = 8 ) yp(neqn)
!    which accepts input values T and Y(1:NEQN), evaluates the right hand
!    sides of the ODE, and stores the result in YP(1:NEQN).
!
!    Input, integer NEQN, the number of equations.
!
!    Input/output, real ( kind = 8 ) Y(NEQN), the current solution.
!
!    Input/output, real ( kind = 8 ) T, the current value of the independent
!    variable.
!
!    Input, real ( kind = 8 ) TOUT, the desired value of T on output.
!
!    Input, real ( kind = 8 ) RELERR, ABSERR, the relative and absolute error
!    tolerances.  At each step, the code requires
!      abs ( local error ) <= abs ( y ) * relerr + abserr
!    for each component of the local error and solution vectors.
!
!    Input/output, integer IFLAG, indicates the status of
!    integration.  On input, IFLAG is normally 1 (or -1 in the special case
!    where TOUT is not to be exceeded.)  On normal output, IFLAG is 2.  Other
!    output values are:
!    * 3, integration did not reach TOUT because the error tolerances
!      were too small.  But RELERR and ABSERR were increased appropriately
!      for continuing;
!    * 4, integration did not reach TOUT because more than 500 steps were taken;
!    * 5, integration did not reach TOUT because the equations appear to
!      be stiff;
!    * 6, invalid input parameters (fatal error).
!    The value of IFLAG is returned negative when the input value is
!    negative and the integration does not reach TOUT.
!
!    Input/output, real ( kind = 8 ) WORK(100+21*NEQN), workspace.
!
!    Input/output, integer IWORK(5), workspace.
!
  implicit none

  integer neqn

  real ( kind = 8 ) abserr
  external f
  integer, parameter :: ialpha = 1
  integer, parameter :: ibeta = 13
  integer, parameter :: idelsn = 93
  integer iflag
  integer, parameter :: ig = 62
  integer, parameter :: ih = 89
  integer, parameter :: ihold = 90
  integer ip
  integer, parameter :: iphase = 75
  integer iphi
  integer, parameter :: ipsi = 76
  integer, parameter :: isig = 25
  integer, parameter :: istart = 91
  integer, parameter :: itold = 92
  integer, parameter :: iv = 38
  integer, parameter :: iw = 50
  integer iwt
  integer, parameter :: ix = 88
  integer iyp
  integer iypout
  integer, parameter :: iyy = 100
  integer iwork(5)
  logical nornd
  logical phase1
  real ( kind = 8 ) relerr
  logical start
  real ( kind = 8 ) t
  real ( kind = 8 ) tout
  real ( kind = 8 ) work(100+21*neqn)
  real ( kind = 8 ) y(neqn)

  iwt = iyy + neqn
  ip = iwt + neqn
  iyp = ip + neqn
  iypout = iyp + neqn
  iphi = iypout + neqn

  if ( abs ( iflag ) /= 1 ) then
    start = ( 0.0D+00 < work(istart) )
    phase1 = ( 0.0D+00 < work(iphase) )
    nornd = ( iwork(2) /= -1 )
  end if

  call de ( f, neqn, y, t, tout, relerr, abserr, iflag, work(iyy), &
    work(iwt), work(ip), work(iyp), work(iypout), work(iphi), &
    work(ialpha), work(ibeta), work(isig), work(iv), work(iw), work(ig), &
    phase1, work(ipsi), work(ix), work(ih), work(ihold), start, &
    work(itold), work(idelsn), iwork(1), nornd, iwork(3), iwork(4), &
    iwork(5) )

  if ( start ) then
    work(istart) = 1.0D+00
  else
    work(istart) = -1.0D+00
  end if

  if ( phase1 ) then
    work(iphase) = 1.0D+00
  else
    work(iphase) = -1.0D+00
  end if

  if ( nornd ) then
    iwork(2) = 1
  else
    iwork(2) = -1
  end if

  return
end
subroutine de ( f, neqn, y, t, tout, relerr, abserr, iflag, yy, wt, p, yp, &
  ypout, phi, alpha, beta, sig, v, w, g, phase1, psi, x, h, hold, start, &
  told, delsgn, ns, nornd, k, kold, isnold )

!*****************************************************************************80
!
!! DE carries out the ODE solution algorithm.
!
!  Discussion:
!
!    ODE merely allocates storage for DE, to relieve the user of the
!    inconvenience of a long call list.  Consequently, DE is used as
!    described in the comments for ODE.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    02 August 2009
!
!  Author:
!
!    Original FORTRAN77 version by Lawrence Shampine, Marilyn Gordon.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Lawrence Shampine, Marilyn Gordon,
!    Computer Solution of Ordinary Differential Equations:
!    The Initial Value Problem,
!    Freeman, 1975,
!    ISBN: 0716704617,
!    LC: QA372.S416.
!
!  Parameters:
!
!    Input, external F, the name of a user-supplied routine of the form
!      subroutine f ( t, y, yp )
!      real ( kind = 8 ) t
!      real ( kind = 8 ) y(neqn)
!      real ( kind = 8 ) yp(neqn)
!    which accepts input values T and Y(1:NEQN), evaluates the right hand
!    sides of the ODE, and stores the result in YP(1:NEQN).
!
!    Input, integer NEQN, the number of equations.
!
!    Input/output, real ( kind = 8 ) Y(NEQN), the current solution.
!
!    Input/output, real ( kind = 8 ) T, the current value of the independent
!    variable.
!
!    Input, real ( kind = 8 ) TOUT, the desired value of T on output.
!
!    Input, real ( kind = 8 ) RELERR, ABSERR, the relative and absolute error
!    tolerances.  At each step, the code requires
!      abs ( local error ) <= abs ( Y ) * RELERR + ABSERR
!    for each component of the local error and solution vectors.
!
!    Input/output, integer IFLAG, indicates the status of
!    integration.  On input, IFLAG is normally 1 (or -1 in the special case
!    where TOUT is not to be exceeded.)  On normal output, IFLAG is 2.  Other
!    output values are:
!    * 3, integration did not reach TOUT because the error tolerances were
!         too small.
!         But RELERR and ABSERR were increased appropriately for continuing;
!    * 4, integration did not reach TOUT because more than 500 steps were taken;
!    * 5, integration did not reach TOUT because the equations appear to be
!         stiff;
!    * 6, invalid input parameters (fatal error).
!    The value of IFLAG is returned negative when the input value is negative
!    and the integration does not reach TOUT.
!
!    Workspace, real ( kind = 8 ) YY(NEQN), used to hold old solution data.
!
!    Input, real ( kind = 8 ) WT(NEQN), the error weight vector.
!
!    Workspace, real ( kind = 8 ) P(NEQN).
!
!    Workspace, real ( kind = 8 ) YP(NEQN), used to hold values of the
!    solution derivative.
!
!    Workspace, real ( kind = 8 ) YPOUT(NEQN), used to hold values of the
!    solution derivative.
!
!    Workspace, real ( kind = 8 ) PHI(NEQN,16), contains divided difference
!    information about the polynomial interpolant to the solution.
!
!    Workspace, real ( kind = 8 ) ALPHA(12), BETA(12), SIG(13).
!
!    Workspace, real ( kind = 8 ) V(12), W(12), G(13).
!
!    Input/output, logical PHASE1, indicates whether the program is in the
!    first phase, when it always wants to increase the ODE method order.
!
!    Workspace, real ( kind = 8 ) PSI(12), contains information about
!    the polynomial interpolant to the solution.
!
!    Input/output, real ( kind = 8 ) X, a "working copy" of T, the current value
!    of the independent variable, which is adjusted as the code attempts
!    to take a step.
!
!    Input/output, real ( kind = 8 ) H, the current stepsize.
!
!    Input/output, real ( kind = 8 ) HOLD, the last successful stepsize.
!
!    Input/output, logical START, is TRUE on input for the first step.
!    The program initializes data, and sets START to FALSE.
!
!    Input/output, real ( kind = 8 ) TOLD, the previous value of T.
!
!    Input/output, real ( kind = 8 ) DELSGN, the sign (+1 or -1) of
!    TOUT - T.
!
!    Input/output, integer NS, the number of steps taken with
!    stepsize H.
!
!    Input/output, logical NORND, ?
!
!    Input, integer K, the order of the current ODE method.
!
!    Input, integer KOLD, the order of the ODE method on the
!    previous step.
!
!    Input/output, integer ISNOLD, the previous value of ISN, the
!    sign of IFLAG.
!
!  Local parameters:
!
!    Local, integer MAXNUM, the maximum number of steps allowed in one
!    call to DE.
!
  implicit none

  integer neqn

  real ( kind = 8 ) absdel
  real ( kind = 8 ) abseps
  real ( kind = 8 ) abserr
  real ( kind = 8 ) alpha(12)
  real ( kind = 8 ) beta(12)
  logical crash
  real ( kind = 8 ) del
  real ( kind = 8 ) delsgn
  real ( kind = 8 ) eps
  external f
  real ( kind = 8 ) fouru
  real ( kind = 8 ) g(13)
  real ( kind = 8 ) h
  real ( kind = 8 ) hold
  integer iflag
  integer isn
  integer isnold
  integer k
  integer kle4
  integer kold
  integer, parameter :: maxnum = 500
  logical nornd
  integer nostep
  integer ns
  real ( kind = 8 ) p(neqn)
  real ( kind = 8 ) phi(neqn,16)
  logical phase1
  real ( kind = 8 ) psi(12)
  real ( kind = 8 ) releps
  real ( kind = 8 ) relerr
  real ( kind = 8 ) sig(13)
  logical start
  logical stiff
  real ( kind = 8 ) t
  real ( kind = 8 ) tend
  real ( kind = 8 ) told
  real ( kind = 8 ) tout
  real ( kind = 8 ) v(12)
  real ( kind = 8 ) w(12)
  real ( kind = 8 ) wt(neqn)
  real ( kind = 8 ) x
  real ( kind = 8 ) y(neqn)
  real ( kind = 8 ) yp(neqn)
  real ( kind = 8 ) ypout(neqn)
  real ( kind = 8 ) yy(neqn)
!
!  Test for improper parameters.
!
  fouru = 4.0D+00 * epsilon ( fouru )

  if ( neqn < 1 ) then
    iflag = 6
    return
  end if

  if ( t == tout ) then
    iflag = 6
    return
  end if

  if ( relerr < 0.0D+00 .or. abserr < 0.0D+00 ) then
    iflag = 6
    return
  end if

  eps = max ( relerr, abserr )

  if ( eps <= 0.0D+00 ) then
    iflag = 6
    return
  end if

  if ( iflag == 0 ) then
    iflag = 6
    return
  end if

  isn = sign ( 1, iflag )
  iflag = abs ( iflag )

  if ( iflag /= 1 ) then

    if ( t /= told ) then
      iflag = 6
      return
    end if

    if ( iflag < 2 .or. 5 < iflag ) then
      iflag = 6
      return
    end if
  end if
!
!  On each call set interval of integration and counter for number of
!  steps.  Adjust input error tolerances to define weight vector for
!  subroutine STEP.
!
  del = tout - t
  absdel = abs ( del )

  if ( isn < 0 ) then
    tend = tout
  else
    tend = t + 10.0D+00 * del
  end if

  nostep = 0
  kle4 = 0
  stiff = .false.
  releps = relerr / eps
  abseps = abserr / eps
!
!  On start and restart, also set work variables X and YY(*), store the
!  direction of integration, and initialize the step size.
!
  if ( iflag == 1 .or. isnold < 0 .or. delsgn * del <= 0.0D+00 ) then

    start = .true.
    x = t
    yy(1:neqn) = y(1:neqn)
    delsgn = sign ( 1.0D+00, del )
    h = sign ( max ( abs ( tout - x ), fouru * abs ( x ) ), tout - x )

  end if
!
!  If already past the output point, then interpolate and return.
!
  do

    if ( absdel <= abs ( x - t ) ) then
      call intrp ( x, yy, tout, y, ypout, neqn, kold, phi, psi )
      iflag = 2
      t = tout
      told = t
      isnold = isn
      exit
    end if
!
!  If we cannot go past the output point, and we are sufficiently
!  close to it, then extrapolate and return.
!
    if ( isn <= 0 .and. abs ( tout - x ) < fouru * abs ( x ) ) then
      h = tout - x
      call f ( x, yy, yp )
      y(1:neqn) = yy(1:neqn) + h * yp(1:neqn)
      iflag = 2
      t = tout
      told = t
      isnold = isn
      exit
    end if
!
!  Test for too many steps.
!
    if ( maxnum <= nostep ) then
      iflag = isn * 4
      if ( stiff ) then
        iflag = isn * 5
      end if
      y(1:neqn) = yy(1:neqn)
      t = x
      told = t
      isnold = 1
      exit
    end if
!
!  Limit the step size, set the weight vector and take a step.
!
    h = sign ( min ( abs ( h ), abs ( tend - x ) ), h )
    wt(1:neqn) = releps * abs ( yy(1:neqn) ) + abseps

    call step ( x, yy, f, neqn, h, eps, wt, start, &
      hold, k, kold, crash, phi, p, yp, psi, &
      alpha, beta, sig, v, w, g, phase1, ns, nornd )
!
!  Test for tolerances too small.
!
    if ( crash ) then
      iflag = isn * 3
      relerr = eps * releps
      abserr = eps * abseps
      y(1:neqn) = yy(1:neqn)
      t = x
      told = t
      isnold = 1
      exit
    end if
!
!  Augment the step counter and test for stiffness.
!
    nostep = nostep + 1
    kle4 = kle4 + 1

    if ( 4 < kold ) then
      kle4 = 0
    end if

    if ( 50 <= kle4 ) then
      stiff = .true.
    end if

  end do

  return
end
subroutine step ( x, y, f, neqn, h, eps, wt, start, hold, k, kold, crash, &
  phi, p, yp, psi, alpha, beta, sig, v, w, g, phase1, ns, nornd )

!*****************************************************************************80
!
!! STEP integrates the system of ODE's one step, from X to X+H.
!
!  Discussion:
!
!    This routine integrates a system of first order ordinary differential
!    equations one step, normally from x to x+h, using a modified divided
!    difference form of the Adams PECE formulas.  Local extrapolation is
!    used to improve absolute stability and accuracy.  The code adjusts its
!    order and step size to control the local error per unit step in a
!    generalized sense.  Special devices are included to control roundoff
!    error and to detect when the user is requesting too much accuracy.
!
!    STEP is normally not called directly by the user.  However, it is
!    possible to do so.
!
!    On the first call to STEP, the user must pass in values for:
!    * X, the initial value of the independent variable;
!    * Y, the vector of initial values of dependent variables;
!    * NEQN, the number of equations to be integrated;
!    * H, the nominal step size indicating direction of integration
!      and maximum size of step.  H must be a variable, not a constant;
!    * EPS, the local error tolerance per step.  EPS must be variable;
!    * WT, the vector of non-zero weights for error criterion;
!    * START, set to TRUE.
!
!    STEP requires the L2 norm of the vector with components
!      local error(1:NEQN) / WT(1:NEQN)
!    to be less than EPS for a successful step.  The array WT allows the user
!    to specify an error test appropriate for the problem.  For example,
!    if WT(L):
!    = 1.0, specifies absolute error,
!    = abs(Y(L)), specifies error relative to the most recent value of
!      the L-th component of the solution,
!    = abs(YP(L)), specifies error relative to the most recent value of
!      the L-th component of the derivative,
!    = max (WT(L),abs(Y(L))), specifies error relative to the largest
!      magnitude of L-th component obtained so far,
!    = abs(Y(L))*RELERR/EPS + ABSERR/EPS, specifies a mixed
!      relative-absolute test where EPS = max ( RELERR, ABSERR ).
!
!    On subsequent calls to STEP, the routine is designed so that all
!    information needed to continue the integration, including the next step
!    size H and the next order K, is returned with each step.  With the
!    exception of the step size, the error tolerance, and the weights, none
!    of the parameters should be altered.  The array WT must be updated after
!    each step to maintain relative error tests like those above.
!
!    Normally the integration is continued just beyond the desired endpoint
!    and the solution interpolated there with subroutine INTRP.  If it is
!    impossible to integrate beyond the endpoint, the step size may be
!    reduced to hit the endpoint since the code will not take a step
!    larger than the H input.
!
!    Changing the direction of integration, that is, the sign of H, requires
!    the user to set START = TRUE before calling STEP again.  This is the
!    only situation in which START should be altered.
!
!    A successful step: the subroutine returns after each successful step with
!    START and CRASH both set to FALSE.  X represents the independent variable
!    advanced by one step of length HOLD from its input value; Y has been
!    updated to the solution vector at the new value of X.  All other parameters
!    represent information corresponding to the new X needed to continue the
!    integration.
!
!    Unsuccessful steps: when the error tolerance is too small, the subroutine
!    returns without taking a step and sets CRASH to TRUE. An appropriate step
!    size and error tolerance for continuing are estimated and all other
!    information is restored as upon input before returning.  To continue
!    with the larger tolerance, the user just calls the code again.  A
!    restart is neither required nor desirable.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    02 August 2009
!
!  Author:
!
!    Original FORTRAN77 version by Lawrence Shampine, Marilyn Gordon.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Lawrence Shampine, Marilyn Gordon,
!    Computer Solution of Ordinary Differential Equations:
!    The Initial Value Problem,
!    Freeman, 1975,
!    ISBN: 0716704617,
!    LC: QA372.S416.
!
!  Parameters:
!
!    Input/output, real ( kind = 8 ) X, the value of the independent variable.
!
!    Input/output, real ( kind = 8 ) Y(NEQN), the approximate solution at the
!    current value of the independent variable.
!
!    Input, external F, the name of a user-supplied routine of the form
!      subroutine f ( t, y, yp )
!      real ( kind = 8 ) t
!      real ( kind = 8 ) y(neqn)
!      real ( kind = 8 ) yp(neqn)
!    which accepts input values T and Y(1:NEQN), evaluates the right hand
!    sides of the ODE, and stores the result in YP(1:NEQN).
!
!    Input, integer NEQN, the number of equations.
!
!    Input/output, real ( kind = 8 ) H, the suggested stepsize.
!
!    Input/output, real ( kind = 8 ) EPS, the local error tolerance.
!
!    Input, real ( kind = 8 ) WT(NEQN), the vector of error weights.
!
!    Input/output, logical START, is set to TRUE before the first step.
!    The program initializes data, and resets START to FALSE.
!
!    Input/output, real ( kind = 8 ) HOLD, the step size used on the last
!    successful step.
!
!    Input/output, integer K, the appropriate order for the
!    next step.
!
!    Input/output, integer KOLD, the order used on the last
!    successful step.
!
!    Output, logical CRASH, is set to TRUE if no step can be taken.
!
!    Workspace, real ( kind = 8 ) PHI(NEQN,16), contains divided difference
!    information about the polynomial interpolant to the solution.
!
!    Workspace, real ( kind = 8 ) P(NEQN).
!
!    Workspace, real ( kind = 8 ) YP(NEQN), used to hold values of the
!    solution derivative.
!
!    Workspace, real ( kind = 8 ) PSI(12), contains information about
!    the polynomial interpolant to the solution.
!
!    Workspace, real ( kind = 8 ) ALPHA(12), BETA(12), SIG(13).
!
!    Workspace, real ( kind = 8 ) V(12), W(12), G(13).
!
!    Input/output, logical PHASE1, indicates whether the program is in the
!    first phase, when it always wants to increase the ODE method order.
!
!    Input/output, integer NS, the number of steps taken with
!    stepsize H.
!
!    Input/output, logical NORND, ?
!
  implicit none

  integer neqn

  real ( kind = 8 ) absh
  real ( kind = 8 ) alpha(12)
  real ( kind = 8 ) beta(12)
  logical crash
  real ( kind = 8 ) eps
  real ( kind = 8 ) erk
  real ( kind = 8 ) erkm1
  real ( kind = 8 ) erkm2
  real ( kind = 8 ) erkp1
  real ( kind = 8 ) err
  external f
  real ( kind = 8 ) fouru
  real ( kind = 8 ) g(13)
  real ( kind = 8 ), dimension ( 13 ) :: gstr = (/ &
    0.50D+00,    0.0833D+00,  0.0417D+00,  0.0264D+00,  0.0188D+00, &
    0.0143D+00,  0.0114D+00,  0.00936D+00, 0.00789D+00, 0.00679D+00, &
    0.00592D+00, 0.00524D+00, 0.00468D+00 /)
  real ( kind = 8 ) h
  real ( kind = 8 ) hnew
  real ( kind = 8 ) hold
  integer i
  integer ifail
  integer iq
  integer j
  integer k
  integer km1
  integer km2
  integer knew
  integer kold
  integer kp1
  integer kp2
  integer l
  logical nornd
  integer ns
  integer nsp1
  real ( kind = 8 ) p(neqn)
  real ( kind = 8 ) p5eps
  logical phase1
  real ( kind = 8 ) phi(neqn,16)
  real ( kind = 8 ) psi(12)
  real ( kind = 8 ) r
  real ( kind = 8 ) rho
  real ( kind = 8 ) round
  real ( kind = 8 ) sig(13)
  logical start
  real ( kind = 8 ) total
  real ( kind = 8 ) tau
  real ( kind = 8 ) temp1
  real ( kind = 8 ) temp2
  real ( kind = 8 ), dimension ( 13 ) :: two = (/ &
       2.0D+00,    4.0D+00,    8.0D+00,  16.0D+00,   32.0D+00, &
      64.0D+00,  128.0D+00,  256.0D+00, 512.0D+00, 1024.0D+00, &
    2048.0D+00, 4096.0D+00, 8192.0D+00/)
  real ( kind = 8 ) twou
  real ( kind = 8 ) v(12)
  real ( kind = 8 ) w(12)
  real ( kind = 8 ) wt(neqn)
  real ( kind = 8 ) x
  real ( kind = 8 ) xold
  real ( kind = 8 ) y(neqn)
  real ( kind = 8 ) yp(neqn)

  twou = 2.0D+00 * epsilon ( twou )
  fouru = 2.0D+00 * twou
!
!  Check if the step size or error tolerance is too small.  If this is the
!  first step, initialize the PHI array and estimate a starting step size.
!
!  If the step size is too small, determine an acceptable one.
!
  crash = .true.

  if ( abs ( h ) < fouru * abs ( x ) ) then
    h = sign ( fouru * abs ( x ), h )
    return
  end if

  p5eps = 0.5D+00 * eps
!
!  If the error tolerance is too small, increase it to an acceptable value.
!
  round = twou * sqrt ( sum ( ( y(1:neqn) / wt(1:neqn) )**2 ) )

  if ( p5eps < round ) then
    eps = 2.0D+00 * round * ( 1.0D+00 + fouru )
    return
  end if

  crash = .false.
  g(1) = 1.0D+00
  g(2) = 0.5D+00
  sig(1) = 1.0D+00
!
!  Initialize.  Compute an appropriate step size for the first step.
!
  if ( start ) then

    call f ( x, y, yp )
    phi(1:neqn,1) = yp(1:neqn)
    phi(1:neqn,2) = 0.0D+00
    total = sqrt ( sum ( ( yp(1:neqn) / wt(1:neqn) )**2 ) )
    absh = abs ( h )
    if ( eps < 16.0D+00 * total * h * h ) then
      absh = 0.25D+00 * sqrt ( eps / total )
    end if
    h = sign ( max ( absh, fouru * abs ( x ) ), h )
    hold = 0.0D+00
    k = 1
    kold = 0
    start = .false.
    phase1 = .true.
    nornd = .true.

    if ( p5eps <= 100.0D+00 * round ) then
      nornd = .false.
      phi(1:neqn,15) = 0.0D+00
    end if

  end if

  ifail = 0
!
!  Compute coefficients of formulas for this step.  Avoid computing
!  those quantities not changed when step size is not changed.
!
  do

    kp1 = k + 1
    kp2 = k + 2
    km1 = k - 1
    km2 = k - 2
!
!  NS is the number of steps taken with size H, including the current
!  one.  When K < NS, no coefficients change.
!
    if ( h /= hold ) then
      ns = 0
    end if

    if ( ns <= kold ) then
      ns = ns + 1
    end if

    nsp1 = ns + 1
!
!  Compute those components of ALPHA, BETA, PSI and SIG which change.
!
    if ( ns <= k ) then

      beta(ns) = 1.0D+00
      alpha(ns) = 1.0D+00 / real ( ns, kind = 8 )
      temp1 = h * real ( ns, kind = 8 )
      sig(nsp1) = 1.0D+00

      do i = nsp1, k
        temp2 = psi(i-1)
        psi(i-1) = temp1
        beta(i) = beta(i-1) * psi(i-1) / temp2
        temp1 = temp2 + h
        alpha(i) = h / temp1
        sig(i+1) = real ( i, kind = 8 ) * alpha(i) * sig(i)
      end do

      psi(k) = temp1
!
!  Compute coefficients G.
!
!  Initialize V and set W.
!
      if ( ns <= 1 ) then

        do iq = 1, k
          v(iq) = 1.0D+00 / real ( iq * ( iq + 1 ), kind = 8 )
          w(iq) = v(iq)
        end do
!
!  If order was raised, update the diagonal part of V.
!
      else

        if ( kold < k ) then

          v(k) = 1.0D+00 / real ( k * kp1, kind = 8 )

          do j = 1, ns - 2
            i = k - j
            v(i) = v(i) - alpha(j+1) * v(i+1)
          end do

        end if
!
!  Update V and set W.
!
        do iq = 1, kp1 - ns
          v(iq) = v(iq) - alpha(ns) * v(iq+1)
          w(iq) = v(iq)
        end do
        g(nsp1) = w(1)

      end if
!
!  Compute the G in the work vector W.
!
      do i = ns + 2, kp1
        do iq = 1, kp2 - i
          w(iq) = w(iq) - alpha(i-1) * w(iq+1)
        end do
        g(i) = w(1)
      end do

    end if
!
!  Predict a solution P, evaluate derivatives using predicted
!  solution, estimate local error at order K and errors at orders K,
!  K-1, K-2 as if a constant step size were used.
!
!  Change PHI to PHI star.
!
    do i = nsp1, k
      phi(1:neqn,i) = beta(i) * phi(1:neqn,i)
    end do
!
!  Predict solution and differences.
!
    phi(1:neqn,kp2) = phi(1:neqn,kp1)
    phi(1:neqn,kp1) = 0.0D+00
    p(1:neqn) = 0.0D+00

    do j = 1, k
      i = kp1 - j
      do l = 1, neqn
        p(l) = p(l) + phi(l,i) * g(i)
        phi(l,i) = phi(l,i) + phi(l,i+1)
      end do
    end do

    if ( .not. nornd ) then
      do l = 1, neqn
        tau = h * p(l) - phi(l,15)
        p(l) = y(l) + tau
        phi(l,16) = ( p(l) - y(l) ) - tau
      end do
    else
      p(1:neqn) = y(1:neqn) + h * p(1:neqn)
    end if

    xold = x
    x = x + h
    absh = abs ( h )
    call f ( x, p, yp )
!
!  Estimate the errors at orders K, K-1 and K-2.
!
    erkm2 = 0.0D+00
    erkm1 = 0.0D+00
    erk = 0.0D+00

    do l = 1, neqn

      if ( 0 < km2 ) then
        erkm2 = erkm2 + ( ( phi(l,km1) + yp(l) - phi(l,1) ) / wt(l) )**2
      end if

      if ( 0 <= km2 ) then
        erkm1 = erkm1 + ( ( phi(l,k) + yp(l) - phi(l,1) ) / wt(l) )**2
      end if

      erk = erk + ( ( yp(l) - phi(l,1) ) / wt(l) )**2

    end do

    if ( 0 < km2 ) then
      erkm2 = absh * sig(km1) * gstr(km2) * sqrt ( erkm2 )
    end if

    if ( 0 <= km2 ) then
      erkm1 = absh * sig(k) * gstr(km1) * sqrt ( erkm1 )
    end if

    err = absh * sqrt ( erk ) * ( g(k) - g(kp1) )
    erk = absh * sqrt ( erk ) * sig(kp1) * gstr(k)
    knew = k
!
!  Test if the order should be lowered.
!
    if ( 0 < km2 ) then

      if ( max ( erkm1, erkm2 ) <= erk ) then
        knew = km1
      end if

    else if ( 0 == km2 ) then

      if ( erkm1 <= 0.5D+00 * erk ) then
        knew = km1
      end if

    end if
!
!  Test if the step was successful.
!
    if ( err <= eps ) then
      exit
    end if
!
!  The step is unsuccessful.  Restore X, PHI and PSI.
!  If third consecutive failure, set order to one.  If the step fails more
!  than three times, consider an optimal step size.  Double the error
!  tolerance and return if the estimated step size is too small for machine
!  precision.
!
!  Restore X, PHI and PSI.
!
    phase1 = .false.
    x = xold
    do i = 1, k
      phi(1:neqn,i) = ( phi(1:neqn,i) - phi(1:neqn,i+1) ) / beta(i)
    end do

    do i = 2, k
      psi(i-1) = psi(i) - h
    end do
!
!  On third failure, set the order to one.  Thereafter, use optimal step size.
!
    ifail = ifail + 1
    temp2 = 0.5D+00

    if ( 3 < ifail ) then

      if ( p5eps < 0.25D+00 * erk ) then
        temp2 = sqrt ( p5eps / erk )
      end if
    end if

    if ( 3 <= ifail ) then
      knew = 1
    end if

    h = temp2 * h
    k = knew

    if ( abs ( h ) < fouru * abs ( x ) ) then
      crash = .true.
      h = sign ( fouru * abs ( x ), h )
      eps = eps + eps
      return
    end if

  end do
!
!  The step is successful.  Correct the predicted solution, evaluate
!  the derivatives using the corrected solution and update the
!  differences.  Determine best order and step size for next step.
!
  kold = k
  hold = h
!
!  Correct and evaluate.
!
  if ( .not. nornd ) then
    do l = 1, neqn
      rho = h * g(kp1) * ( yp(l) - phi(l,1) ) - phi(l,16)
      y(l) = p(l) + rho
      phi(l,15) = ( y(l) - p(l) ) - rho
    end do
  else
    y(1:neqn) = p(1:neqn) + h * g(kp1) * ( yp(1:neqn) - phi(1:neqn,1) )
  end if

  call f ( x, y, yp )
!
!  Update differences for the next step.
!
  phi(1:neqn,kp1) = yp(1:neqn) - phi(1:neqn,1)
  phi(1:neqn,kp2) = phi(1:neqn,kp1) - phi(1:neqn,kp2)

  do i = 1, k
    phi(1:neqn,i) = phi(1:neqn,i) + phi(1:neqn,kp1)
  end do
!
!  Estimate error at order K+1 unless:
!  * in first phase when always raise order, or,
!  * already decided to lower order, or,
!  * step size not constant so estimate unreliable.
!
  erkp1 = 0.0D+00

  if ( knew == km1 .or. k == 12 ) then
    phase1 = .false.
  end if

  if ( phase1 ) then

    k = kp1
    erk = erkp1

  else if ( knew == km1 ) then

    k = km1
    erk = erkm1

  else if ( kp1 <= ns ) then

    do l = 1, neqn
      erkp1 = erkp1 + ( phi(l,kp2) / wt(l) )**2
    end do
    erkp1 = absh * gstr(kp1) * sqrt ( erkp1 )
!
!  Using estimated error at order K+1, determine appropriate order
!  for next step.
!
    if ( k == 1 ) then

      if ( erkp1 < 0.5D+00 * erk ) then
        k = kp1
        erk = erkp1
      end if

    else if ( erkm1 <= min ( erk, erkp1 ) ) then

      k = km1
      erk = erkm1

    else if ( erkp1 < erk .and. k < 12 ) then

      k = kp1
      erk = erkp1

    end if

  end if
!
!  With the new order, determine appropriate step size for next step.
!
  hnew = h + h

  if ( .not. phase1 ) then

    if ( p5eps < erk * two(k+1) ) then

      hnew = h

      if ( p5eps < erk ) then
        temp2 = real ( k + 1, kind = 8 )
        r = ( p5eps / erk )**( 1.0D+00 / temp2 )
        hnew = absh * max ( 0.5D+00, min ( 0.9D+00, r ) )
        hnew = sign ( max ( hnew, fouru * abs ( x ) ), h )
      end if

    end if

  end if

  h = hnew

  return
end
subroutine intrp ( x, y, xout, yout, ypout, neqn, kold, phi, psi )

!*****************************************************************************80
!
!! INTRP approximates the solution at XOUT by polynomial interpolation.
!
!  Discussion:
!
!    The methods in STEP approximate the solution near X by a polynomial.
!    This routine approximates the solution at XOUT by evaluating the
!    polynomial there.  Information defining this polynomial is passed
!    from STEP, so INTRP cannot be used alone.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    02 August 2009
!
!  Author:
!
!    Original FORTRAN77 version by Lawrence Shampine, Marilyn Gordon.
!    FORTRAN90 version by John Burkardt.
!
!  Reference:
!
!    Lawrence Shampine, Marilyn Gordon,
!    Computer Solution of Ordinary Differential Equations:
!    The Initial Value Problem,
!    Freeman, 1975,
!    ISBN: 0716704617,
!    LC: QA372.S416.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) X, the point where the solution has been computed.
!
!    Input, real ( kind = 8 ) Y(NEQN), the computed solution at X.
!
!    Input, real ( kind = 8 ) XOUT, the point at which the solution is desired.
!
!    Output, real ( kind = 8 ) YOUT(NEQN), the solution at XOUT.
!
!    Output, real ( kind = 8 ) YPOUT(NEQN), the derivative of the solution
!    at XOUT.
!
!    Input, integer NEQN, the number of equations.
!
!    Input, integer KOLD, the order used for the last
!    successful step.
!
!    Input, real ( kind = 8 ) PHI(NEQN,16), contains information about the
!    interpolating polynomial.
!
!    Input, real ( kind = 8 ) PSI(12), contains information about the
!    interpolating polynomial.
!
  implicit none

  integer neqn

  real ( kind = 8 ) eta
  real ( kind = 8 ) g(13)
  real ( kind = 8 ) gamma
  real ( kind = 8 ) hi
  integer i
  integer j
  integer ki
  integer kold
  real ( kind = 8 ) phi(neqn,16)
  real ( kind = 8 ) psi(12)
  real ( kind = 8 ) psijm1
  real ( kind = 8 ) rho(13)
  real ( kind = 8 ) term
  real ( kind = 8 ) w(13)
  real ( kind = 8 ) x
  real ( kind = 8 ) xout
  real ( kind = 8 ) y(neqn)
  real ( kind = 8 ) yout(neqn)
  real ( kind = 8 ) ypout(neqn)

  hi = xout - x
  ki = kold + 1
!
!  Initialize W for computing G.
!
  do i = 1, ki
    w(i) = 1.0D+00 / real ( i, kind = 8 )
  end do
!
!  Compute G.
!
  g(1) = 1.0D+00
  rho(1) = 1.0D+00
  term = 0.0D+00

  do j = 2, ki
    psijm1 = psi(j-1)
    gamma = ( hi + term ) / psijm1
    eta = hi / psijm1
    do i = 1, ki + 1 - j
      w(i) = gamma * w(i) - eta * w(i+1)
    end do
    g(j) = w(1)
    rho(j) = gamma * rho(j-1)
    term = psijm1
  end do
!
!  Interpolate.
!
  ypout(1:neqn) = 0.0D+00
  yout(1:neqn) = 0.0D+00

  do j = 1, ki
    i = ki + 1 - j
    yout(1:neqn) = yout(1:neqn) + g(i) * phi(1:neqn,i)
    ypout(1:neqn) = ypout(1:neqn) + rho(i) * phi(1:neqn,i)
  end do

  yout(1:neqn) = y(1:neqn) + hi * yout(1:neqn)

  return
end
subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    31 May 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 May 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer d
  integer h
  integer m
  integer mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer n
  integer s
  integer values(8)
  integer y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(i2.2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end