SUBROUTINE comsub(bk,loads)
! performs the complete gaussian backsubstitution  : complex version
IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
COMPLEX(iwp),INTENT(IN)::bk(:);COMPLEX(iwp),INTENT(IN OUT)::loads(0:)
INTEGER::nkb,k,i,jn,jj,i1,n,iw; COMPLEX::sum
n = UBOUND(loads,1); iw = UBOUND(bk,1)/n - 1
loads(1)=loads(1)/bk(1)
   DO i=2,n
      sum=loads(i);i1=i-1 ; nkb=i-iw
      IF(nkb<=0)nkb=1
      DO k=nkb,i1
         jn=(i-k)*n+k;sum=sum-bk(jn)*loads(k)
      END DO
      loads(i)=sum/bk(i)
   END DO
   DO jj=2,n
      i=n-jj+1;sum=.0;i1=i+1;nkb=i+iw
      if(nkb-n>0)nkb=n
      DO k=i1,nkb
           jn=(k-i)*n+i  ; sum=sum+bk(jn)*loads(k)
      END DO
      loads(i)=loads(i)-sum/bk(i)
   END DO
RETURN
END SUBROUTINE comsub


! =========================================================
subroutine rp1(maxmx,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
! =========================================================

! solve Riemann problem for the 1D shallow water equations using the HLLE
! approximate Riemann solver.

! waves: 2
! equations: 2

! Conserved quantities:
!       1 depth (h)
!       2 momentum (hu)

    implicit none

    integer, intent(in) :: maxmx, meqn, mwaves, mbc, mx, maux
    double precision, dimension(meqn,1-mbc:maxmx+mbc), intent(in) :: ql, qr
    double precision, dimension(maux,1-mbc:maxmx+mbc), intent(in) :: auxl, auxr
    double precision, dimension(meqn, mwaves, 1-mbc:maxmx+mbc), intent(out) :: wave
    double precision, dimension(meqn, 1-mbc:maxmx+mbc), intent(out) :: amdq, apdq
    double precision, dimension(mwaves, 1-mbc:maxmx+mbc), intent(out) :: s

    double precision :: u_l, u_r, h_l, h_r, c_l, c_r
    double precision :: hsqrt_l, hsqrt_r, u_hat, h_hat, c_hat, grav
    double precision :: h_m, hu_m
    double precision :: rho_m, rhou_m, E_m, s1, s2
    integer :: m, i, mw

    common /cparam/  grav

    do i=2-mbc,mx+mbc
        h_l = qr(1,i-1)
        h_r = ql(1,i)
        u_l = qr(2,i-1) / qr(1,i-1)
        u_r = ql(2,i  ) / ql(1,i  )
        c_l = dsqrt(grav*h_l)
        c_r = dsqrt(grav*h_r)

        if (h_l<1.e-14 .AND. h_r<1.e-14) then
            wave(1,1,i) =0.
            wave(2,1,i) =0.
            s(1,i) = 0.

            wave(1,2,i) = 0.
            wave(2,2,i) = 0.
            s(2,i) = 0.

        else
            ! Roe averages
            hsqrt_l = dsqrt(qr(1,i-1))
            hsqrt_r = dsqrt(ql(1,i))
            h_hat = 0.5*(h_l + h_r)
            u_hat = (hsqrt_l*u_l + hsqrt_r*u_r) / (hsqrt_l + hsqrt_r)
            c_hat = dsqrt(grav*h_hat)

            s1 = min(u_l - c_l, u_hat - c_hat)
            s2 = max(u_r + c_r, u_hat + c_hat)

            ! Middle state
            h_m = (ql(2,i) - qr(2,i-1) - s2*h_r + s1*h_l) / (s1-s2)
            hu_m = (ql(2,i)*(u_r-s2) - qr(2,i-1)*(u_l-s1) + 0.5*grav*(h_r**2-h_l**2)) / (s1-s2)

            wave(1,1,i) = h_m - h_l
            wave(2,1,i) = hu_m - qr(2,i-1)
            s(1,i) = s1

            wave(1,2,i) = h_r - h_m
            wave(2,2,i) = ql(2,i) - hu_m
            s(2,i) = s2
        end if

    end do

    do m=1, meqn
        do i=2-mbc, mx+mbc
            amdq(m,i) = 0.d0
            apdq(m,i) = 0.d0
            do mw=1, mwaves
                if (s(mw,i) < 0.d0) then
                    amdq(m,i) = amdq(m,i) + s(mw,i)*wave(m,mw,i)
                else
                    apdq(m,i) = apdq(m,i) + s(mw,i)*wave(m,mw,i)
                endif
            end do
        end do
    end do

end subroutine rp1


C	WRITTEN BY: THEODORE E. FESSLER, NASA TM X-3572, AUGUST 1977
C	REWRITTEN BY: LT. MARK D. KLEM & MARGARET P. PROCTOR, JANUARY 1986
C
C	THE ORIGINAL PROGRAM WAS WRITTEN IN SFTRAN, BUT THIS PROGRAM IS
C	REWRITTEN IN STANDARD FORTRAN 77 TO RUN PRIMARILY ON PERSONAL
C	COMPUTERS AND CAN ALSO RUN ON MAINFRAMES. MUCH OF THE OLD CODE WAS
C	COMMENTED OUT BUT LEFT INTACT FOR DOCUMENTATION AND REFERENCE
C	PURPOSES.
C
      SUBROUTINE CUBIC (T,P,ROOTS,NROOTS)
C.....SOLVES FOR DENSITY IN REDUCED VAN DER WAALS GAS:

C        D**3 -3*D**2 +((8*T+P)/3)*D -P = 0

C     IF MORE THAN ONE DISTINCT ROOT EXISTS, ONLY THE MINIMUM AND
C     MAXIMUM ONES ARE RETURNED AND NROOTS=2.

      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 K1,K2
      REAL*4 T,P,ROOTS(2)
      DATA K1,K2,THIRD / 2.094395102393195D+0, 4.188790204786391D+0,
     *                   3.333333333333333D-1 /

C.....FUNCTION DEFINITION.
      QRT(ARG)=DSIGN(DABS(ARG)**THIRD,ARG)

C.....MAIN PROGRAM FLOW.
C     PROCEDURE (REDUCE TO NORMAL FORM)
      Q=(8.0D0*T+P)/3.0D0
      A=Q/3.0D0-1.0D0
      A3=A*A*A
      B=(Q-P)/2.0D0-1.0D0
      B2=B*B
      RAD=A3+B2
      IF (RAD.LT.0.0D0) THEN
C        PROCEDURE (CASE FOR 3 DISTINCT REAL ROOTS)
         PHI=DACOS(DSIGN(DSQRT(-B2/A3),-B))/3.0D0
         CR=2.0D0*DSQRT(-A)
         R1=CR*DCOS(PHI)
         R2=CR*DCOS(PHI+K1)
         R3=CR*DCOS(PHI+K2)
         ROOTS(1)=DMIN1(R1,R2,R3)+1.0D0
         ROOTS(2)=DMAX1(R1,R2,R3)+1.0D0
         NROOTS=2
      ELSE
         IF (RAD.EQ.0.0D0) THEN
            IF (B.EQ.0.0D0) THEN
C              PROCEDURE (CASE FOR ONLY ONE REAL ROOT)
               IF (RAD.NE.0.0D0) RAD=DSQRT(RAD)
               AA=-B+RAD
               BB=-B-RAD
               IF (AA.NE.0.0D0) AA=QRT(AA)
               IF (BB.NE.0.0D0) BB=QRT(BB)
               ROOTS(1)=AA+BB+1.0D0
               NROOTS=1
            ELSE
C              PROCEDURE (CASE FOR 3 REAL ROOTS BUT TWO ARE EQUAL)
               R1=QRT(B)
               R2=-2.0D0*R1
               ROOTS(1)=DMIN1(R1,R2)+1.0D0
               ROOTS(2)=DMAX1(R1,R2)+1.0D0
               NROOTS=2
            ENDIF
         ELSE
C           PROCEDURE (CASE FOR ONLY ONE REAL ROOT)
            IF (RAD.NE.0.0D0) RAD=DSQRT(RAD)
            AA=-B+RAD
            BB=-B-RAD
            IF (AA.NE.0.0D0) AA=QRT(AA)
            IF (BB.NE.0.0D0) BB=QRT(BB)
            ROOTS(1)=AA+BB+1.0D0
            NROOTS=1
         ENDIF
      ENDIF
      END


*> \brief  SSYSV computes the solution to system of linear equations A * X = B for SY matrices
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SSYSV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
*                         LWORK, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            INFO, LDA, LDB, LWORK, N, NRHS
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       REAL               A( LDA, * ), B( LDB, * ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SSYSV computes the solution to a real system of linear equations
*>    A * X = B,
*> where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
*> matrices.
*>
*> The diagonal pivoting method is used to factor A as
*>    A = U * D * U**T,  if UPLO = 'U', or
*>    A = L * D * L**T,  if UPLO = 'L',
*> where U (or L) is a product of permutation and unit upper (lower)
*> triangular matrices, and D is symmetric and block diagonal with
*> 1-by-1 and 2-by-2 diagonal blocks.  The factored form of A is then
*> used to solve the system of equations A * X = B.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          = 'U':  Upper triangle of A is stored;
*>          = 'L':  Lower triangle of A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of linear equations, i.e., the order of the
*>          matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrix B.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array, dimension (LDA,N)
*>          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
*>          N-by-N upper triangular part of A contains the upper
*>          triangular part of the matrix A, and the strictly lower
*>          triangular part of A is not referenced.  If UPLO = 'L', the
*>          leading N-by-N lower triangular part of A contains the lower
*>          triangular part of the matrix A, and the strictly upper
*>          triangular part of A is not referenced.
*>
*>          On exit, if INFO = 0, the block diagonal matrix D and the
*>          multipliers used to obtain the factor U or L from the
*>          factorization A = U*D*U**T or A = L*D*L**T as computed by
*>          SSYTRF.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (N)
*>          Details of the interchanges and the block structure of D, as
*>          determined by SSYTRF.  If IPIV(k) > 0, then rows and columns
*>          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
*>          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
*>          then rows and columns k-1 and -IPIV(k) were interchanged and
*>          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and
*>          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
*>          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
*>          diagonal block.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is REAL array, dimension (LDB,NRHS)
*>          On entry, the N-by-NRHS right hand side matrix B.
*>          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (MAX(1,LWORK))
*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The length of WORK.  LWORK >= 1, and for best performance
*>          LWORK >= max(1,N*NB), where NB is the optimal blocksize for
*>          SSYTRF.
*>          for LWORK < N, TRS will be done with Level BLAS 2
*>          for LWORK >= N, TRS will be done with Level BLAS 3
*>
*>          If LWORK = -1, then a workspace query is assumed; the routine
*>          only calculates the optimal size of the WORK array, returns
*>          this value as the first entry of the WORK array, and no error
*>          message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0: successful exit
*>          < 0: if INFO = -i, the i-th argument had an illegal value
*>          > 0: if INFO = i, D(i,i) is exactly zero.  The factorization
*>               has been completed, but the block diagonal matrix D is
*>               exactly singular, so the solution could not be computed.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup realSYsolve
*
*  =====================================================================
      SUBROUTINE SSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
     $                  LWORK, INFO )
*
*  -- LAPACK driver routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, LDB, LWORK, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      REAL               A( LDA, * ), B( LDB, * ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            LWKOPT
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, SSYTRF, SSYTRS, SSYTRS2
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
      IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
         INFO = -10
      END IF
*
      IF( INFO.EQ.0 ) THEN
         IF( N.EQ.0 ) THEN
            LWKOPT = 1
         ELSE
            CALL SSYTRF( UPLO, N, A, LDA, IPIV, WORK, -1, INFO )
            LWKOPT = WORK(1)
         END IF
         WORK( 1 ) = LWKOPT
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SSYSV ', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Compute the factorization A = U*D*U**T or A = L*D*L**T.
*
      CALL SSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
      IF( INFO.EQ.0 ) THEN
*
*        Solve the system A*X = B, overwriting B with X.
*
         IF ( LWORK.LT.N ) THEN
*
*        Solve with TRS ( Use Level BLAS 2)
*
            CALL SSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
         ELSE
*
*        Solve with TRS2 ( Use Level BLAS 3)
*
            CALL SSYTRS2( UPLO,N,NRHS,A,LDA,IPIV,B,LDB,WORK,INFO )
*
         END IF
*
      END IF
*
      WORK( 1 ) = LWKOPT
*
      RETURN
*
*     End of SSYSV
*
      END


subroutine vecres(norm,n,v1,v2,redif,zero)

!-----------------------------------------------------------------------
!
! Compute the relative difference between two vectors:
!
! redif = 1*||v1 - v2|| / ||v1||
!
!-----------------------------------------------------------------------
  use      typre
  implicit none
  integer(ip), intent(in)  :: n,norm
  real(rp),    intent(in)  :: v1(n),v2(n),zero
  real(rp),    intent(out) :: redif
  integer(ip)              :: i
  real(rp)                 :: numer,denom,va,vo

  redif = 0.0_rp
  numer = 0.0_rp
  denom = 0.0_rp

  select case(norm)

  case(0)
     do i = 1,n
        va = v1(i)
        vo = v2(i)
        numer = max(numer,abs(va-vo))
        denom = max(denom,abs(va))
     end do
     if(denom.gt.zero) redif = 1.0_rp*numer/denom

  case(1)
     do i = 1,n
        va = v1(i)
        vo = v2(i)
        numer = numer + abs(va-vo)
        denom = denom + abs(va)
     end do
     if(denom>zero) redif = 1.0_rp*numer/denom

  case(2)
     do i = 1,n
        va = v1(i)
        vo = v2(i)
        numer = numer + (va-vo)*(va-vo)
        denom = denom + va*va
     end do
     if(denom>zero) redif = 1.0_rp*sqrt(numer/denom)

  end select

end subroutine vecres

subroutine vecresMPI(norm,n,v1,v2,redif,zero,kfl_MPIComType,MPIcomm,MPIroot,MPIrank,MPIsize)

!-----------------------------------------------------------------------
!
! Compute the relative difference between two vectors:
!
! redif = 100*||v1 - v2|| / ||v1||
!
!-----------------------------------------------------------------------
  use typre
  use MPI
  implicit none
  integer(ip), intent(in)  :: n,norm
  real(rp),    intent(in)  :: v1(n),v2(n),zero
  real(rp),    intent(out) :: redif
  integer(ip), intent(in)  :: kfl_MPIComType,MPIcomm,MPIroot,MPIrank,MPIsize
  integer(ip)              :: i
  real(rp)                 :: numer,denom,va,vo,rwa(2),rwa2(2)
  integer                  :: ierr

  redif = 0.0_rp
  numer = 0.0_rp
  denom = 0.0_rp

  select case(norm)

  case(0)
     do i = 1,n
        va = v1(i)
        vo = v2(i)
        numer = max(numer,abs(va-vo))
        denom = max(denom,abs(va))
     end do

     rwa(1) = numer
     rwa(2) = denom
     call MPI_REDUCE_Implementation(2_ip,rwa,rwa2,kfl_MPIComType,MPIcomm,MPIrank,MPIroot,MPIsize)
     numer = rwa2(1)
     denom = rwa2(2)

     if(denom.gt.zero) redif = 1.0_rp*numer/denom
  case(1)
     do i = 1,n
        va = v1(i)
        vo = v2(i)
        numer = numer + abs(va-vo)
        denom = denom + abs(va)
     end do

     rwa(1) = numer
     rwa(2) = denom
     call MPI_REDUCE_Implementation(2_ip,rwa,rwa2,kfl_MPIComType,MPIcomm,MPIrank,MPIroot,MPIsize)
     numer = rwa2(1)
     denom = rwa2(2)

     if(denom>zero) redif = 1.0_rp*numer/denom
  case(2)
     do i = 1,n
        va = v1(i)
        vo = v2(i)
        numer = numer + (va-vo)*(va-vo)
        denom = denom + va*va
     end do

     rwa(1) = numer
     rwa(2) = denom
     call MPI_REDUCE_Implementation(2_ip,rwa,rwa2,kfl_MPIComType,MPIcomm,MPIrank,MPIroot,MPIsize)
     numer = rwa2(1)
     denom = rwa2(2)

     if(denom>zero) redif = 1.0_rp*sqrt(numer/denom)
  end select

contains

end subroutine vecresMPI

subroutine MPI_REDUCE_Implementation(rwasize,rwa,rwa2,kfl_MPIComType,MPIcomm,MPIrank,MPIroot,MPIsize)
   use typre
   use MPI
   implicit none
   integer(ip) :: rwasize, MPIcomm,MPIrank,MPIroot,MPIsize,kfl_MPIComType
   real(rp) :: rwa(rwasize),rwa2(rwasize)

   real(rp) :: auxrwa2(2,MPIsize)
   integer(ip) :: irank,isize

   !MPI
   integer, parameter :: mtag1 = 1, mtag2 = 2
   integer :: irequest, irequest01(MPIsize)
   integer status(MPI_STATUS_SIZE)
   integer :: ierr

   !Blocking
   if (kfl_MPIComType == 0) then
      call  MPI_REDUCE( rwa, rwa2, rwasize, MPI_REAL8, MPI_SUM, MPIroot,MPIcomm, ierr )
   !Non-Blocking
   else
      !Everybody sends to root
      call MPI_ISEND(rwa,rwasize,MPI_REAL8, MPIroot, mtag1, MPIcomm,irequest, ierr)

      !Root receives
      if (MPIrank == MPIroot) then
         do irank = 0,MPIsize-1
            call MPI_IRECV(auxrwa2(:,irank+1), rwasize, MPI_REAL8, irank, mtag1, MPIcomm,irequest01(irank+1), ierr)
         enddo
         do irank = 0,MPIsize-1
            call MPI_WAIT(irequest01(irank+1), status,ierr)
         enddo
         do isize = 1,rwasize
            rwa2(isize) = sum(auxrwa2(isize,:))
         enddo
      endif
      call MPI_WAIT(irequest, status, ierr)
   endif
end subroutine

subroutine vecresMPIHeterogeneous(norm,ndime1,ndime2,npoinLocal,startcomp1,startcomp2,ncomp,v1,v2,redif,zero,MPIcomm,MPIroot)

!-----------------------------------------------------------------------
!
! Compute the relative difference between two vectors:
!
! redif = 100*||v1 - v2|| / ||v1||
!
!-----------------------------------------------------------------------
  use typre
  use MPI
  implicit none
  integer(ip), intent(in)  :: ndime1,ndime2,ncomp,startcomp1,startcomp2,norm,npoinLocal
  real(rp),    intent(in)  :: v1(ndime1,npoinLocal),v2(ndime2,npoinLocal),zero
  real(rp),    intent(out) :: redif
  integer(ip)              :: i,MPIcomm,MPIroot,idime
  real(rp)                 :: numer,denom,va,vo,rwa(2),rwa2(2)
  integer                  :: ierr

  redif = 0.0_rp
  numer = 0.0_rp
  denom = 0.0_rp

  select case(norm)

  case(0)
     do i = 1,npoinLocal
        do idime = 0,ncomp-1
         va = v1(startcomp1+idime,i)
         vo = v2(startcomp2+idime,i)
         numer = max(numer,abs(va-vo))
         denom = max(denom,abs(va))
        enddo
     end do

     rwa(1) = numer
     rwa(2) = denom
     call  MPI_REDUCE( rwa, rwa2, 2, MPI_REAL8, MPI_SUM, MPIroot,MPIcomm, ierr )
     numer = rwa2(1)
     denom = rwa2(2)

     if(denom.gt.zero) redif = 1.0_rp*numer/denom

  case(1)
      do i = 1,npoinLocal
        do idime = 0,ncomp-1
         va = v1(startcomp1+idime,i)
         vo = v2(startcomp2+idime,i)
         numer = numer + abs(va-vo)
         denom = denom + abs(va)
        enddo
     end do

     rwa(1) = numer
     rwa(2) = denom
     call  MPI_REDUCE( rwa, rwa2, 2, MPI_REAL8, MPI_SUM, MPIroot,MPIcomm, ierr )
     numer = rwa2(1)
     denom = rwa2(2)

     if(denom>zero) redif = 1.0_rp*numer/denom

  case(2)
     do i = 1,npoinLocal
        do idime = 0,ncomp-1
         va = v1(startcomp1+idime,i)
         vo = v2(startcomp2+idime,i)
         numer = numer + (va-vo)*(va-vo)
         denom = denom + va*va
        enddo
     end do

     rwa(1) = numer
     rwa(2) = denom
     call  MPI_REDUCE( rwa, rwa2, 2, MPI_REAL8, MPI_SUM, MPIroot,MPIcomm, ierr )
     numer = rwa2(1)
     denom = rwa2(2)

     if(denom>zero) redif = 1.0_rp*sqrt(numer/denom)

  end select

end subroutine vecresMPIHeterogeneous


program array_arithmetic
    implicit none
    real, dimension(5) :: A = [ 1.2, 2.3, 3.4, 4.5, 5.6 ], &
                          B = [ -1.0, -0.5, 0.0, 0.5, 1.0], &
                          C

    C = A + 2.0*B
    print *, C
end program array_arithmetic


! { dg-do run }
! Test assorted intrinsics for integer kinds 1 and 2
program main
  integer(kind=1), dimension(2,2) :: a
  integer(kind=2), dimension(2,2) :: b
  integer(kind=1), dimension(2) :: r1
  integer(kind=2), dimension(2) :: r2
  logical, dimension(2,2) :: ma
  ma = .false.
  a = reshape((/ 1_1, 2_1, 3_1, 4_1/), shape(a))
  b = reshape((/ 1_2, 2_2, 3_2, 4_2/), shape(b))
  if (any(sum(a,dim=2) /= (/ 4, 6 /))) STOP 1
  if (any(sum(b,dim=2) /= (/ 4, 6 /))) STOP 2
  if (any(product(a,dim=2) /= (/ 3, 8 /))) STOP 3
  if (any(product(b,dim=2) /= (/ 3, 8 /))) STOP 4
  if (any(matmul(a,a) /= reshape ( (/ 7, 10, 15, 22 /), shape(a)))) STOP 5
  if (any(matmul(b,b) /= reshape ( (/ 7, 10, 15, 22 /), shape(b)))) STOP 6
  if (any(maxval(a,dim=2,mask=ma) /= -128)) STOP 7
  if (any(maxval(b,dim=2,mask=ma) /= -32768)) STOP 8
end program main


program main
    use ArrayClass
    implicit none

    type(Array_) :: A, B, C, I, str_array
    real(real64),allocatable :: vector(:),small_vector(:)
    integer(int32),allocatable :: vector_int(:)
    real(real64),allocatable :: matrix(:,:)
    integer(int32),allocatable :: matrix_int(:,:)

    print *, " "
    call A%random(3,3)
    call B%zeros(3,3)
    call I%unit(3,3)

    C = A * B ! A_ij B_jk

    C = A + B ! A_ij + B_ij

    call A%print()
    call B%print()
    call C%print()
    call I%print()

    print *, dot(C, C)

    ! create vectors
    print *, "zeros"
    vector = zeros(5) ! Five 0
    call print(vector)

    ! hstack
    print *, "hstack"
    small_vector = [10.0d0, 20.0d0, 30.0d0, 40.0d0]
    call print( hstack(vector, small_vector) )

    ! np.arange
    print *, "arange"
    vector = arange(5) ! 1, 2, 3 , 4, 5
    call print(vector)

    ! np.arange
    print *, "arange : start, stop, step"
    vector = arange(10, 50, 5) ! 1, 2, 3 , 4, 5
    call print(vector)

    ! np.arange
    print *, "arange : start, stop, step"
    vector_int = int(arange(10, 50, 5)) ! 1, 2, 3 , 4, 5
    call print(vector_int)

    ! reshape
    print *, "arange : start, stop, step"
    matrix = reshape(vector, 7, 3 )
    call print(matrix)

    ! reshape int
    print *, "arange : start, stop, step"
    matrix_int = reshape(vector_int, 7,  3 )
    call print(matrix_int)

    ! allocate string-array
    allocate(str_array%list(4,4) )
    str_array%list(1,1)%string = "hello"
    str_array%list(1,2)%string = "hello"
    str_array%list(1,3)%string = "hello"
    str_array%list(1,4)%string = "hello"
    str_array%list(1,2)%string = "oka"
    str_array%list(3,1)%string = "hoge"
    str_array%list(1,4)%string = "piyo"
    call str_array%print()

end program


     program demo_M_display
     use M_display
     implicit none
     integer, parameter :: rk = selected_real_kind(6), n = 3
     real(rk) :: a(n,n), b(n,n), x
     integer i, j, k(5)
       call disp_set(advance = 'double')
       forall(i=1:n, j=1:n)
         a(i,j) = exp(real(i+j-1, rk))
         b(i,j) = exp(real(i**j, rk))
       end forall
       call disp('A = ', a)
       call disp(b)
       call disp(a(1:2,:),'f0.5')
       call disp('MATRIX', a, style='UNDERLINE & NUMBER', unit=-3, digmax=4)
       k = [-3,0,12,14,0]
       call disp('K', k, style='pad', orient='row', sep=' ', zeroas='.')
       x = 1.5
       call disp('The square of '//tostring(x)//' is '//tostring(x*x))
       call disp_set(matsep = ' | ')
       call disp([11,12,13], advance='no')
       call disp([.true., .false., .true.], advance='no')
       call disp(['A','B','C'])
     end program demo_M_display


MODULE Bivariate_Trivariate_Normal

! Appendix: Fortran Source Code

! Code converted using TO_F90 by Alan Miller
! Date: 2001-02-25  Time: 11:57:13
! Latest revision - 25 February 2001
! amiller @ bigpond.net.au

!     Code from Alan Genz's web site for bivariate & trivariate
!     normal integrals, adapted by Alan Miller.

!     http://www.sci.wsu.edu/math/faculty/genz/papers/

!     Alan C Genz
!     2001-01-22

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

! COMMON /trvbkd/b2p, b3p, rho21, rho31, rho
REAL (dp), SAVE  :: b2p, b3p, rho21, rho31, rho

CONTAINS

FUNCTION bvn( sh, sk, r ) RESULT(fn_val)

!     A function for computing bivariate normal probabilities.
!     This function uses an algorithm given in the paper
!        "Numerical Computation of Bivariate and
!             Trivariate Normal Probabilities", by
!       Alan Genz
!       Department of Mathematics
!       Washington State University
!       Pullman, WA 99164-3113
!       Email : alangenz@wsu.edu

! BVN - calculate the probability that X is larger than SH, and Y is
!       larger than SK.

! Parameters

!   SH  REAL, integration limit
!   SK  REAL, integration limit
!   R   REAL, correlation coefficient
!   LG  INTEGER, number of Gauss Rule Points and Weights

REAL, INTENT(IN)  :: sh, sk, r
REAL              :: fn_val

REAL, PARAMETER     :: zero = 0, twopi = 6.283185
INTEGER, PARAMETER  :: lg = 5
REAL, PARAMETER     :: x(lg) =  &
                       (/ -0.9061798, -0.5384693, 0.0, 0.5384693, 0.9061798 /)
!          X(I) = +-SQRT((5+-SQRT(10/7))/9), 0
REAL, PARAMETER     :: w(lg) =  &
                       (/ 0.2369269,  0.4786287, 0.5688889, 0.4786287, 0.2369269 /)

INTEGER  :: i
REAL     :: as, a, b, c, rs, xs
REAL     :: sn, asr, h, k, bs, hs, hk

h = sh
k = sk
hk = h*k
fn_val = 0

!     Absolute value of the correlation coefficient is less than 0.8

IF ( ABS(r) < 0.8 ) THEN
  hs = ( h*h + k*k )/2
  asr = ASIN( r )/2
  DO i = 1, lg
    sn = SIN( asr*(x(i)+1) )
    fn_val = fn_val + w(i)*EXP( ( sn*hk - hs )/( 1 - sn*sn ) )
  END DO
  fn_val = asr*fn_val/twopi + phi(-h)*phi(-k)
ELSE

!     For larger correlation coefficient

  IF ( r < 0 ) THEN
    k = -k
    hk = -hk
  END IF
  IF ( ABS(r) < 1 ) THEN
    as = ( 1 - r )*( 1 + r )
    a = SQRT( as )
    bs = ( h - k )**2
    c = ( 4 - hk )/8
    fn_val = a*EXP( -(bs/as + hk)/2 )*( 1 - c*(bs - as)/3 )
    IF ( -hk < 100 ) THEN
      b = SQRT(bs)
      fn_val = fn_val - EXP(-hk/2)*SQRT(twopi)*phi(-b/a)*b*(1-c*bs/3)
    END IF
    a = a/2
    DO i = 1, lg
      xs = ( a*( x(i) + 1 ) )**2
      rs = SQRT( 1 - xs )
      asr = -( bs/xs + hk )/2
      IF ( asr > -100 ) fn_val = fn_val + a*w(i)*   &
                        ( EXP(-bs/(2*xs) - hk/(1+rs))/rs - EXP(asr)*(1+c*xs) )
    END DO
    fn_val = -fn_val/twopi
  END IF
  IF ( r > 0 ) fn_val =  fn_val + phi( -MAX( h, k ) )
  IF ( r < 0 ) fn_val = -fn_val + MAX( zero, phi(-h) - phi(-k) )
END IF

RETURN
END FUNCTION bvn

FUNCTION phi(x) RESULT(fn_val)

REAL, INTENT(IN)  :: x
REAL              :: fn_val

fn_val = phid( REAL(x, KIND=dp) )
RETURN
END FUNCTION phi

FUNCTION bvnd( dh, dk, r ) RESULT(fn_val)

!     A function for computing bivariate normal probabilities.

!       Alan Genz
!       Department of Mathematics
!       Washington State University
!       Pullman, WA 99164-3113
!       Email : alangenz@wsu.edu

!    This function is based on the method described by
!        Drezner, Z and G.O. Wesolowsky, (1989),
!        On the computation of the bivariate normal inegral,
!        Journal of Statist. Comput. Simul. 35, pp. 101-107,
!    with major modifications for REAL (dp), and for |R| close to 1.

! BVND - calculate the probability that X is larger than DH, and Y is
!       larger than DK.

! Parameters

!   DH  REAL (dp), integration limit
!   DK  REAL (dp), integration limit
!   R   REAL (dp), correlation coefficient

REAL (dp), INTENT(IN)  :: dh, dk, r
REAL (dp)              :: fn_val

REAL (dp), PARAMETER  :: zero = 0.0_dp, twopi = 6.283185307179586_dp

REAL (dp), PARAMETER  :: x(10,3) = RESHAPE(  &
                             !     Gauss Legendre Points, N =  6
     (/ -0.9324695142031522_dp, -0.6612093864662647_dp,  &
        -0.2386191860831970_dp,  0.0_dp, 0.0_dp, 0.0_dp, &
         0.0_dp, 0.0_dp, 0.0_dp, 0.0_dp,  &
                             !     Gauss Legendre Points, N = 12
        -0.9815606342467191_dp, -0.9041172563704750_dp,  &
        -0.7699026741943050_dp, -0.5873179542866171_dp,  &
        -0.3678314989981802_dp, -0.1252334085114692_dp,  &
         0.0_dp, 0.0_dp, 0.0_dp, 0.0_dp,  &
                             !     Gauss Legendre Points, N = 20
        -0.9931285991850949_dp, -0.9639719272779138_dp,  &
        -0.9122344282513259_dp, -0.8391169718222188_dp,  &
        -0.7463319064601508_dp, -0.6360536807265150_dp,  &
        -0.5108670019508271_dp, -0.3737060887154196_dp,  &
        -0.2277858511416451_dp, -0.07652652113349733_dp /), (/ 10, 3 /) )
REAL (dp), PARAMETER  :: w(10,3) = RESHAPE(  &
                             !     Gauss Legendre Weights, N =  6
  (/ 0.1713244923791705_dp, 0.3607615730481384_dp, 0.4679139345726904_dp, &
     0.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, 0.0_dp,  &
                          !     Gauss Legendre Weights, N = 12
     0.04717533638651177_dp, 0.1069393259953183_dp, 0.1600783285433464_dp, &
     0.2031674267230659_dp,  0.2334925365383547_dp, 0.2491470458134029_dp, &
     0.0_dp, 0.0_dp, 0.0_dp, 0.0_dp,  &
                          !     Gauss Legendre Weights, N = 20
     0.01761400713915212_dp, 0.04060142980038694_dp, 0.06267204833410906_dp, &
     0.08327674157670475_dp, 0.1019301198172404_dp, 0.1181945319615184_dp, &
     0.1316886384491766_dp,  0.1420961093183821_dp, 0.1491729864726037_dp, &
     0.1527533871307259_dp /), (/ 10, 3 /) )

INTEGER    :: i, is, lg, ng
REAL (dp)  :: as, a, b, c, d, rs, xs, bvn
REAL (dp)  :: sn, asr, h, k, bs, hs, hk

IF ( ABS(r) < 0.3_dp ) THEN
  ng = 1
  lg = 3
ELSE IF ( ABS(r) < 0.75_dp ) THEN
  ng = 2
  lg = 6
ELSE
  ng = 3
  lg = 10
END IF
h = dh
k = dk
hk = h*k
bvn = 0
IF ( ABS(r) < 0.925_dp ) THEN
  hs = ( h*h + k*k )/2
  asr = ASIN(r)
  DO i = 1, lg
    DO is = -1, 1, 2
      sn = SIN( asr*(  is*x(i,ng) + 1 )/2 )
      bvn = bvn + w(i,ng)*EXP( ( sn*hk - hs )/( 1 - sn*sn ) )
    END DO
  END DO
  bvn = bvn*asr/( 2*twopi ) + phid(-h)*phid(-k)
ELSE
  IF ( r < 0 ) THEN
    k = -k
    hk = -hk
  END IF
  IF ( ABS(r) < 1 ) THEN
    as = ( 1 - r )*( 1 + r )
    a = SQRT(as)
    bs = ( h - k )**2
    c = ( 4 - hk )/8
    d = ( 12 - hk )/16
    asr = -( bs/as + hk )/2
    IF ( asr > -100 ) bvn = a*EXP(asr)  &
                       *( 1 - c*( bs - as )*( 1 - d*bs/5 )/3 + c*d*as*as/5 )
    IF ( -hk < 100 ) THEN
      b = SQRT(bs)
      bvn = bvn - EXP( -hk/2 )*SQRT(twopi)*phid(-b/a)*b  &
            *( 1 - c*bs*( 1 - d*bs/5 )/3 )
    END IF
    a = a/2
    DO i = 1, lg
      DO is = -1, 1, 2
        xs = ( a*(  is*x(i,ng) + 1 ) )**2
        rs = SQRT( 1 - xs )
        asr = -( bs/xs + hk )/2
        IF ( asr > -100 ) THEN
          bvn = bvn + a*w(i,ng)*EXP( asr )  &
                *( EXP( -hk*( 1 - rs )/( 2*( 1 + rs ) ) )/rs  &
                - ( 1 + c*xs*( 1 + d*xs ) ) )
        END IF
      END DO
    END DO
    bvn = -bvn/twopi
  END IF
  IF ( r > 0 ) bvn =  bvn + phid( -MAX( h, k ) )
  IF ( r < 0 ) bvn = -bvn + MAX( zero, phid(-h) - phid(-k) )
END IF

fn_val = bvn
RETURN
END FUNCTION bvnd

FUNCTION tvnd( limit, sigma ) RESULT(fn_val)

!     A function for computing trivariate normal probabilities.
!     This function uses an algorithm given in the paper
!        "Numerical Computation of Bivariate and
!             Trivariate Normal Probabilities",
!     by
!       Alan Genz
!       Department of Mathematics
!       Washington State University
!       Pullman, WA 99164-3113
!       Email : alangenz@wsu.edu

! TVND calculates the probability that X(I) < LIMIT(I), I = 1, 2, 3.

!     Bivariate normal distribution function BVND is required.

! Parameters

!   LIMIT  REAL (dp) array of three upper integration limits.
!   SIGMA  REAL (dp) array of three correlation coefficients,
!          SIGMA should contain the lower left portion of the
!          correlation matrix R.
!          SIGMA(1) = R(2,1), SIGMA(2) = R(3,1), SIGMA(3) = R(3,2).

!    TVND cuts the outer integral over -infinity to B1 to an integral
!      from -8.5 to B1 and then uses an adaptive integration method to
!      compute the integral of a bivariate normal distribution function.

REAL (dp), INTENT(IN)  :: limit(3), sigma(3)
REAL (dp)              :: fn_val

! EXTERNAL trvfnd
! COMMON /trvbkd/b2p, b3p, rho21, rho31, rho

LOGICAL   :: tail
REAL (dp) :: sq21, sq31
REAL (dp) :: b1, b2, b3, rho32
REAL (dp), PARAMETER :: sqtwpi = 2.506628274631000_dp, xcut = -8.5_dp,  &
                        eps = 5D-16

b1 = limit(1)
b2 = limit(2)
b3 = limit(3)
rho21 = sigma(1)
rho31 = sigma(2)
rho32 = sigma(3)
IF ( ABS(b2) >= MAX( ABS(b1), ABS(b3) ) ) THEN
  b1 = b2
  b2 = limit(1)
  rho31 = rho32
  rho32 = sigma(2)
ELSE IF ( ABS(b3) >= MAX( ABS(b1), ABS(b2) ) ) THEN
  b1 = b3
  b3 = limit(1)
  rho21 = rho32
  rho32 = sigma(1)
END IF
tail = .false.
IF ( b1 > 0 ) THEN
  tail = .true.
  b1 = -b1
  rho21 = -rho21
  rho31 = -rho31
END IF
IF ( b1 > xcut ) THEN
  IF ( 2*ABS(rho21) < 1 ) THEN
    sq21 = SQRT( 1 - rho21**2 )
  ELSE
    sq21 = SQRT( ( 1 - rho21 )*( 1 + rho21 ) )
  END IF
  IF ( 2*ABS(rho31) < 1 ) THEN
    sq31 = SQRT( 1 - rho31**2 )
  ELSE
    sq31 = SQRT( ( 1 - rho31 )*( 1 + rho31 ) )
  END IF
  rho = ( rho32 - rho21*rho31 )/(sq21*sq31)
  b2p = b2/sq21
  rho21 = rho21/sq21
  b3p = b3/sq31
  rho31 = rho31/sq31
  fn_val = adoned( trvfnd, xcut, b1, eps )/sqtwpi
ELSE
  fn_val = 0
END IF
IF ( tail ) fn_val = bvnd( -b2, -b3, rho32 ) - fn_val

RETURN
END FUNCTION tvnd

FUNCTION trvfnd(t) RESULT(fn_val)

REAL (dp), INTENT(IN)  :: t
REAL (dp)              :: fn_val

! COMMON /trvbkd/b2, b3, rho21, rho31, rho

fn_val = EXP( -t*t/2 )*bvnd(t*rho21 - b2p, t*rho31 - b3p, rho)
RETURN
END FUNCTION trvfnd

FUNCTION adoned( f, a, b, tol ) RESULT(fin)

!     One Dimensional Globally Adaptive Integration Function

REAL (dp), INTENT(IN)  :: a, b, tol
REAL (dp)              :: fin

! EXTERNAL f

INTERFACE
  FUNCTION f(x) RESULT(fn_val)
    IMPLICIT NONE
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)
    REAL (dp), INTENT(IN)  :: x
    REAL (dp)              :: fn_val
  END FUNCTION f
END INTERFACE

INTEGER, PARAMETER  :: nl = 100
REAL (dp)  :: ei(nl), ai(nl), bi(nl), fi(nl), ERR
INTEGER    :: i, im, ip

ip = 1
ai(ip) = a
bi(ip) = b
CALL krnrdd( ai(ip), bi(ip), f, ei(ip), fi(ip) )
im = 1
10   im = im + 1
bi(im) = bi(ip)
ai(im) = (ai(ip) + bi(ip))/2
bi(ip) = ai(im)
fin = fi(ip)
CALL krnrdd( ai(ip), bi(ip), f, ei(ip), fi(ip) )
CALL krnrdd( ai(im), bi(im), f, ei(im), fi(im) )
ERR = ABS( fin - fi(ip) - fi(im) )/2
ei(ip) = ei(ip) + ERR
ei(im) = ei(im) + ERR
ip = 1
ERR = 0
fin = 0
DO i = 1, im
  IF ( ei(i) > ei(ip) ) ip = i
  fin = fin + fi(i)
  ERR = ERR + ei(i)
END DO
IF ( ERR > tol .AND. im < nl ) GO TO 10

RETURN
END FUNCTION adoned

SUBROUTINE krnrdd( a, b, f, abserr, fn_val)

!     Kronrod Rule

REAL (dp), INTENT(IN)   :: a, b
REAL (dp), INTENT(OUT)  :: abserr, fn_val

! EXTERNAL f

INTERFACE
  FUNCTION f(x) RESULT(fn_val)
    IMPLICIT NONE
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)
    REAL (dp), INTENT(IN)  :: x
    REAL (dp)              :: fn_val
  END FUNCTION f
END INTERFACE

REAL (dp)  :: abscis, center, fc, funsum, hflgth, resltg, resltk

!     The abscissae and weights are given for the interval (-1,1)
!     because of symmetry only the positive abscisae and their
!     corresponding weights are given.

!     XGK    - abscissae of the 2N+1-point Kronrod rule:
!              XGK(2), XGK(4), ...  N-point Gauss rule abscissae;
!              XGK(1), XGK(3), ...  abscissae optimally added
!              to the N-point Gauss rule.

!     WGK    - weights of the 2N+1-point Kronrod rule.

!     WG     - weights of the N-point Gauss rule.

INTEGER  :: j
INTEGER, PARAMETER :: n = 11

REAL (dp), PARAMETER  :: wg(0:n/2) = (/  &
     0.2729250867779007_dp, 0.05566856711617449_dp, 0.1255803694649048_dp,  &
     0.1862902109277352_dp, 0.2331937645919914_dp, 0.2628045445102478_dp  /)
REAL (dp), PARAMETER  :: xgk(0:n) = (/  &
     0.0000000000000000_dp, 0.9963696138895427_dp, 0.9782286581460570_dp,   &
     0.9416771085780681_dp, 0.8870625997680953_dp, 0.8160574566562211_dp,   &
     0.7301520055740492_dp, 0.6305995201619651_dp, 0.5190961292068118_dp,   &
     0.3979441409523776_dp, 0.2695431559523450_dp, 0.1361130007993617_dp /)
REAL (dp), PARAMETER  :: wgk(0:n) = (/  &
     0.1365777947111183_dp, 0.9765441045961290D-02, 0.2715655468210443D-01, &
     0.4582937856442671D-01, 0.6309742475037484D-01, 0.7866457193222764D-01, &
     0.9295309859690074D-01, 0.1058720744813894_dp, 0.1167395024610472_dp,  &
     0.1251587991003195_dp, 0.1312806842298057_dp, 0.1351935727998845_dp /)

!     List of major variables

!     CENTER  - mid point of the interval
!     HFLGTH  - half-length of the interval
!     ABSCIS   - abscissae
!     RESLTG   - result of the N-point Gauss formula
!     RESLTK   - result of the 2N+1-point Kronrod formula

hflgth = ( b - a )/2
center = ( b + a )/2

!           compute the 2N+1-point Kronrod approximation to
!           the integral, and estimate the absolute error.

fc = f(center)
resltg = fc*wg(0)
resltk = fc*wgk(0)
DO j = 1, n
  abscis = hflgth*xgk(j)
  funsum = f( center - abscis ) + f( center + abscis )
  resltk = resltk + wgk(j)*funsum
  IF( MOD( j, 2 ) == 0 ) resltg = resltg + wg(j/2)*funsum
END DO
fn_val = resltk*hflgth
abserr = 3*ABS( ( resltk - resltg )*hflgth )

RETURN
END SUBROUTINE krnrdd

FUNCTION phid(z) RESULT(fn_val)

! Normal distribution probabilities accurate to 1.e-15.
! Z = no. of standard deviations from the mean.
! P, Q = probabilities to the left & right of Z.   P + Q = 1.
!       PDF = the probability density.

!       Based upon algorithm 5666 for the error function, from:
!       Hart, J.F. et al, 'Computer Approximations', Wiley 1968

!       Programmer: Alan Miller, modified by Alan Genz

! Latest revision of Fortran 77 version - 30 March 1986
! Latest revision of Fortran 90 version - 23 June 1997

IMPLICIT NONE
INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(12, 60)
REAL (dp), INTENT(IN)  :: z
REAL (dp)              :: fn_val

! Local variables
REAL (dp), PARAMETER :: p0 = 220.2068679123761_dp, p1 = 221.2135961699311_dp,  &
                        p2 = 112.0792914978709_dp, p3 = 33.91286607838300_dp,  &
                        p4 = 6.373962203531650_dp, p5 = .7003830644436881_dp,  &
                        p6 = 0.03526249659989109_dp,  &
                        q0 = 440.4137358247522_dp, q1 = 793.8265125199484_dp,  &
                        q2 = 637.3336333788311_dp, q3 = 296.5642487796737_dp,  &
                        q4 = 86.78073220294608_dp, q5 = 16.06417757920695_dp,  &
                        q6 = 1.755667163182642_dp, q7 = .8838834764831844D-1, &
                        cutoff = 7.071067811865475_dp

REAL (dp)            :: zabs, expntl

zabs = ABS(z)

! |Z| > 37.

IF (zabs > 37._dp) THEN
    fn_val = 0._dp
  ELSE

! |Z| <= 37.

    expntl = EXP(-0.5_dp*zabs**2)

! |Z| < CUTOFF = 10/sqrt(2).

  IF (zabs < cutoff) THEN
      fn_val = expntl*((((((p6*zabs + p5)*zabs + p4)*zabs + p3)*zabs + p2)*zabs     &
                 + p1)*zabs + p0) / (((((((q7*zabs + q6)*zabs + q5)*zabs &
                 + q4)*zabs + q3)*zabs + q2)*zabs + q1)*zabs +q0)

! |Z| >= CUTOFF.

  ELSE
    fn_val = expntl/(zabs + 1._dp/(zabs + 2._dp/(zabs + 3._dp/(zabs +  &
                     4._dp/(zabs + 0.65_dp)))))
  END IF
END IF

IF (z > 0.0_dp) fn_val = 1.0_dp - fn_val

RETURN
END FUNCTION phid

END MODULE Bivariate_Trivariate_Normal


MODULE group_theory
use utilities, only : ralloc
implicit none
private
public grouper

CONTAINS

  !!<summary>Generates a group from a list of generators</summary>
  !!<usage>Pass in 2D array where the rows are the permutations. The
  !!permutations will be taken in all possible pairs to generate new
  !!group elements. The array of elements will be added to until the
  !!list of permutations has closure and constitutes a group.</usage>
  !!<comments>Permutations are indexed 1..n, not 0..n-1</comments>
  !!<parameter name="g" regular="true">On entry contains the
  !!generators, on exit contains the whole group </parameter>
  subroutine grouper(g)
    integer, pointer:: g(:,:)

    integer :: nG ! Number of elements in the group (on exit)
    logical :: growing, new ! Flags: group is still being added to,
    ! new group element was found
    integer :: mG ! Number of elements already checked (don't need to be re-checked)
    integer :: ig, jg, kg, cg ! Generic loop variables
    integer :: n ! Number of permutation elements
    integer,allocatable :: newg(:), vs(:) ! permuted group element, vector subscript

    n = size(g,2) ! Number of permutation elements
    if (n<1) stop "ERROR: Empty list passed to 'grouper' subroutine in 'group_theory' module (celib)"
    allocate(newg(n),vs(n))
    if(any(g>n) .or. any(g<1)) then
       write(*,'("n: ",i4)') n
       write(*,'("g: ",5000(i3,1x))')
       stop "ERROR: generators passed to 'grouper' (group_theory in celib) contain indices outside of 1..n"
    endif
    growing = .true.
    mG = 0
    nG = size(g,1)
    do while (growing)
       growing = .false.
       g => ralloc(g,nG+nG**2,n) ! Make room for possible new elements
       ! when the existing elements are combined
       ! Loop over each pair of group elements...
       cg = 0 ! Keep track of the number of new elements of the group
       ! that have been found in this iteration
       do ig = 1, nG
          do jg = 1, nG
             if (ig <= mG .and. jg <= mG) cycle !...but skip those
             !already tested in a previous iteration
             ! Construct a permuted element, that is, multiply two group elements
             vs = g(jg,:) ! Make a vector subscript for the permuted element
             newg = g(ig,vs) ! Permute the element
             ! Is this new g unique in the list of existing group elements?
             new = .true.
             newcheck: do kg = 1, nG+cg
                if (all(newg == g(kg,:))) then
                   new = .false.
                   exit newcheck
                endif
             enddo newcheck
             if (new) then
                growing = .true.
                cg = cg + 1
                g(nG+cg,:) = newg
             end if
          end do
       end do ! Loops over pairs
       mG = nG
       nG = nG + cg
    end do ! Loop for group still growing
    g => ralloc(g,nG,n)
  end subroutine grouper
END MODULE group_theory


!>
module m_integrate

  implicit none

contains

  function integrate_trapezoid (n, x, f) result (integral)
    integer , intent(in) :: n
    double precision , intent(in) :: x(n), f(n)
    double precision :: w(n)
    double precision :: integral
    integer :: ii
    integer :: status

    ! check if arguments are valid
    status = 0

    if (n < 2) then
      status = 1
    end if

    ! terminate subroutine if arguments are invalid, otherwise, proceed
    if (status /= 0) then
      integral = 0.0d0
      return
    end if

    ! calculate weights
    w(1) = (x(2) - x(1)) / 2.0d0

    do ii = 2, n-1
      w(ii) = (x(ii+1) - x(ii-1)) / 2.0d0
    end do

    w(n) = (x(n) - x(n-1)) / 2.0d0

    ! calculate integral
    integral = 0.0d0

    do ii = 1, n
      integral = integral + (w(ii) * f(ii))
    end do

  end function integrate_trapezoid

end module m_integrate


program test_dot_product

  write (*, '(i0)') dot_product ((/1, 3, -5/), (/4, -2, -1/))

end program test_dot_product


      subroutine clawpack46_src2(maxmx,maxmy,meqn,mbc,mx,my,
     &      xlower,ylower,dx,dy,q,maux,aux,t,dt)
c =========================================================
      implicit double precision(a-h,o-z)
      dimension    q(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, meqn)
      dimension  aux(1-mbc:maxmx+mbc, 1-mbc:maxmy+mbc, maux)
c
c     # source terms for cylindrical symmetry in 2d Euler equations
c     # about y = 0, so radius = y
c     # y value at cell center is stored in aux(i,j,1)
c
      dimension qstar(4)
      common /cparam/  gamma,gamma1
c
c     # 2-stage Runge-Kutta method
c
      dt2    = dt/2.d0
      press  = 0.d0
      ndim   = 2

      do 10 i=1,mx
       do 10 j=1,my
         rad      = aux(i,j,1)
         rho      = q(i,j,1)
         u        = q(i,j,2)/q(i,j,1)
         v        = q(i,j,3)/q(i,j,1)
         press    = gamma1*(q(i,j,4) - 0.5d0*rho*(u**2 + v**2))

         if (rad.eq.0.d0) write(6,*) 'rad = 0 in src2'
         if (rho.eq.0.d0) write(6,*) 'rho = 0 in q'

         qstar(1) = q(i,j,1) - dt2*(ndim-1)/rad * q(i,j,3)
         qstar(2) = q(i,j,2) - dt2*(ndim-1)/rad *
     &                          (rho*u*v)
         qstar(3) = q(i,j,3) - dt2*(ndim-1)/rad *
     &                          (rho*v*v)
         qstar(4) = q(i,j,4) - dt2*(ndim-1)/rad *
     &                          v*(q(i,j,4) + press)
c
c        # second stage
c
         rho      = qstar(1)
         u        = qstar(2)/qstar(1)
         v        = qstar(3)/qstar(1)
         press    = gamma1*(qstar(4) - 0.5d0*rho*(u**2 + v**2))
         if (rho.eq.0.d0) write(6,*) 'rho = 0 in qstar'

         q(i,j,1) = q(i,j,1) - dt*(ndim-1)/rad * qstar(3)
         q(i,j,2) = q(i,j,2) - dt*(ndim-1)/rad *
     &                          (rho*u*v)
         q(i,j,3) = q(i,j,3) - dt*(ndim-1)/rad *
     &                          (rho*v*v)
         q(i,j,4) = q(i,j,4) - dt*(ndim-1)/rad *
     &                          v*(qstar(4) + press)
   10    continue

      return
      end


!*********************************************************************
      SUBROUTINE mass_bal(var,outflow,conc)
!*********************************************************************
	! jday - julian day of the mass ballance calculation
	! lakemass - mass of variable in the lake
	! inmass - mass of variable in the inflow stack
	! outmass - mass of variable in the outflow
!*********************************************************************
      USE DLMWQ_VARIABLES
      USE DLMWQ_SERVICES
		IMPLICIT NONE
      SAVE

		INTEGER*4:: i,var,k,ntot
		REAL*8:: lakemass, inmass, outmass, massbal, outflow, conc

	! calculate the mass in the lake
		lakemass=0.0d0
		DO i=1,ns
			lakemass=lakemass+wqual(i,var)*vol(i)		! integrate lake mass
		ENDDO

	!Calculate the mass in the inflow stack
		DO i=1,numinf
!		inmass = inmass+floinf(i)*wqual(i,var)		! add in the inflow masses
			DO k=1,icnt(i)
				inmass = qdown(i,k)*wqdown(i,var,k)		! add in inlfow masses including stacks
			ENDDO
		ENDDO

!Calculate the mass in the outflow
		outmass = outflow*conc							! add up outflow masses

		massbal = lakemass-outmass+inmass				! total the mass balance for the step

!		WRITE(83,94)jday,nosecs,lakemass,outmass,massbal
94		FORMAT(2I10,3F16.4)

		END SUBROUTINE mass_bal

!*********************************************************************
      SUBROUTINE h2o_bal(outflow)
!*********************************************************************
	! jday - julian day of the mass ballance calculation
	! lakemass - mass of variable in the lake
	! inmass - mass of variable in the inflow stack
	! outmass - mass of variable in the outflow
!*********************************************************************
      USE DLMWQ_VARIABLES
      USE DLMWQ_SERVICES
		IMPLICIT NONE
      SAVE

		INTEGER*4:: i,k,ntot
		REAL*8:: lakemass, inmass, outmass, massbal, outflow

!		calculate the mass in the lake
		lakemass=0.0d0
		DO i=1,ns
			lakemass=lakemass+vol(i)		! integrate lake mass
		ENDDO

!		Calculate the mass in the inflow stack
		DO i=1,numinf
!		inmass = inmass+floinf(i)*wqual(i,var)		! add in the inflow masses
			inmass=0.0d0
			DO k=1,icnt(i)
				inmass = inmass+qdown(i,k)		! add in inlfow masses including stacks
			ENDDO
		ENDDO

!		Calculate the mass in the outflow

		outmass=outflow
		massbal = lakemass-outmass+inmass				! total the mass balance for the step

!		WRITE(83,94)jday,lakemass,inmass,outmass,massbal
94		FORMAT(I10,4F16.4)
		END SUBROUTINE h2o_bal
!*********************************************************************
!*********************************************************************
		SUBROUTINE injection(var,conc,top,bottom)
!*********************************************************************
	! var - variable to inject
	! conc - concentration of variable to inject
	! top - depth from surface of top of injection layer
	! bottom - depth from surface of bottom of injection layer
!*********************************************************************
      USE DLMWQ_VARIABLES
      USE DLMWQ_SERVICES
		IMPLICIT NONE
      SAVE

		INTEGER*4:: i,var,ntop,nbottom
		REAL*8:: conc,top,bottom

!find layers where top and bottom of injection occur
		nbottom=0							! start with finding the bottom layer
		IF (bottom == depth(ns)) THEN
			nbottom = 1						! nbottom is the bottom layer
		ELSE
			DO WHILE ((depth(ns)-depth(ns-nbottom-1))<bottom)
				nbottom=nbottom+1
			ENDDO
			ns=ns+1							! add the additional layer
			DO i=0,nbottom
				depth(ns-i)=depth(ns-1-i)	! assign depths to layers above split
			ENDDO
			depth(ns-nbottom-1)=depth(ns)-bottom		! assign depth to the split
			nbottom=ns-nbottom				! assign actual layer number of the bottom
			CALL RESINT(1,nbottom-1)		! reset volumes, T, S, and wqual
		ENDIF
!then work on the top layer
		ntop=0								! now find the top layer
		IF (top == 0) THEN
			ntop = ns						! ntop is the top layer
		ELSE
			nbottom=nbottom-1				! bottom will be moved 1 layer down
			DO WHILE ((depth(ns)-depth(ns-ntop-1))<top)
				ntop=ntop+1
			ENDDO
			ns=ns+1							! add the additional layer
			DO i=0,ntop
				depth(ns-i)=depth(ns-1-i)	! assign depths to layers above split
			ENDDO
			depth(ns-ntop-1)=depth(ns)-top			! assign depth to the split
			ntop=ns-ntop-1					! assign actual layer number of the bottom
			CALL RESINT(1,ntop)				! reset volumes, T, S, and wqual
		ENDIF
!add tracer to the desired layers
		DO i=nbottom,ntop
			wqual(i,var)=conc
		ENDDO

		END SUBROUTINE injection

!*********************************************************************


	module kron3_mod
	implicit none

	private

	interface
	subroutine zgemm(transA, transB, m,n,k,
     &		alpha, A, lda, B, ldb, beta, C, ldc )
	character transA, transB
	integer m,n,k,lda,ldb,ldc
	complex*16 alpha,beta, A(*),B(*),C(*)
	end subroutine zgemm
	end interface

	integer, parameter :: idebug = 0
	logical, parameter ::   use_gemm = .true.

	public :: kron2, kron3

	contains

	subroutine kron3( ny1, ny2, ny3, nx1,nx2,nx3,
     &		A, lda, B, ldb, C, ldc,
     &          X, ldx1,ldx2, Y, ldy1,ldy2 )
	implicit none
	integer, intent(in) :: ny1,ny2,ny3, nx1,nx2,nx3
	integer, intent(in) :: lda,ldb,ldc, ldx1,ldx2, ldy1,ldy2

	complex*16, dimension(lda,*), intent(in) :: A
	complex*16, dimension(ldb,*), intent(in) :: B
	complex*16, dimension(ldc,*), intent(in) :: C
	complex*16, dimension(ldx1,ldx2,*), intent(in) :: X
	complex*16, dimension(ldy1,ldy2,*), intent(inout) :: Y

!	-----------------------------------------------------
!	Y(ny1,ny2,ny3) = kron( A, kron(B,C)) * X(nx1,nx2,nx3)
!
!	A is (ny3,nx3), B is (ny2,nx2), C is (ny1,nx1)
!
!	kron(A, kron(B,C))*X = (kron(B,C)*X)*transpose(A)
!
!	Let be BCX(ny1,ny2,nx3) =
!		kron(B(ny2,nx2), C(ny1,nx1))* X(nx1,nx2,nx3)
!
!	-----------------------------------------------------
!	---------------
!	local variables
!	---------------
	complex*16, dimension(:,:), allocatable ::  Xin
	complex*16, dimension(:,:), allocatable ::  Yout, Youtb
	complex*16, dimension(:,:), allocatable ::  A_t
	complex*16, dimension(:,:,:), allocatable :: BCX, BCXb
	real*8 :: err
	integer :: ix1,ix2,ix3, iy1,iy2,iy3
	integer :: ldxin, ldyout

	integer :: mm,nn,kk, ld1,ld2,ld3
	complex*16 :: alpha,beta
!

!	-------------------------------------------------------
!	Note computing kron(A,B,C)*X as
!
!	(kron(B,C)*X)*transpose(A)
!
!	is chosen for convenience in implementation and
!	may not be most efficient in terms of temporary storage
!	or amount of work.
!
!	-------------------------------------------------------

	allocate( BCX(ny1,ny2,nx3) )
	allocate( Xin(nx1,nx2) )
	allocate( Yout(ny1,ny2) )

	do ix3=1,nx3
	   do ix2=1,nx2
	   do ix1=1,nx1
		Xin(ix1,ix2) = X(ix1,ix2,ix3)
	   enddo
	   enddo

	   ldxin = size(Xin,1)
	   ldyout = size(Yout,1)

	   call kron2(  ny1,ny2, nx1,nx2,
     &       B, ldb, C, ldc, Xin, ldxin, Yout,ldyout )

	   do iy2=1,ny2
	   do iy1=1,ny1
		BCX(iy1,iy2,ix3) = Yout(iy1,iy2)
	   enddo
	   enddo

	enddo
	deallocate( Xin )
	deallocate( Yout )

!debug-begin
	if (idebug.ge.2) then
	allocate( BCXb(ny1,ny2,nx3) )
	BCXb(:,:,:) = 0.0

	do ix3=1,nx3
	do iy2=1,ny2
	do iy1=1,ny1

	do ix2=1,nx2
	do ix1=1,nx1

	  BCXb(iy1,iy2,ix3) = BCXb(iy1,iy2,ix3) +
     &      B(iy2,ix2) * C(iy1,ix1) * X(ix1,ix2,ix3)
	enddo
	enddo

	enddo
	enddo
	enddo

	err = maxval( abs(BCXb - BCX) )
	write(*,*) 'err BCXb ', err

        deallocate( BCXb )
	endif
!debug-end

!	----------------------------------------------------
!	Y(1:ny1,1:ny2,1:ny3) =
!		BCX(1:ny1,1:ny2,1:nx3)*tranpose(A(ny3,nx3))
!	----------------------------------------------------
	allocate( A_t(1:nx3,1:ny3) )
	do ix3=1,nx3
	do iy3=1,ny3
	   A_t(ix3,iy3) = A(iy3,ix3)
	enddo
	enddo

	allocate( Xin(1:ny1,1:nx3) )
	allocate( Yout(1:ny1,1:ny3) )

	do iy2=1,ny2
!	   ---------------------------------------
!	   Xin(1:ny1,1:nx3) = BCX(1:ny1,iy2,1:nx3)
!	   ---------------------------------------
	   do ix3=1,nx3
	   do iy1=1,ny1
	     Xin(iy1,ix3) = BCX(iy1,iy2,ix3)
	   enddo
	   enddo

	   if (use_gemm) then
	     mm = ny1
	     nn = ny3
	     kk = nx3
	     ld1 = size(Xin,1)
	     ld2 = size(A_t,1)
	     ld3 = size(Yout,1)
	     alpha = 1.0d0
	     beta = 0.0d0

	     call zgemm( 'N','N', mm,nn,kk,
     &           alpha, Xin, ld1, A_t, ld2, beta, Yout, ld3 )

!debug-begin
	if (idebug.ge.2) then
	     allocate( Youtb(1:ny1,1:ny3) )

	     Youtb(1:ny1,1:ny3) =
     &		matmul( Xin(1:ny1,1:nx3), A_t(1:nx3,1:ny3) )
	     err = maxval(abs(Youtb-Yout))
	     write(*,*) 'err Youtb ', err

	     deallocate( Youtb )
	endif
!debug-end
	   else
	     Yout(1:ny1,1:ny3) =
     &		matmul( Xin(1:ny1,1:nx3), A_t(1:nx3,1:ny3) )
	   endif
!	   ----------------------------------------
!	   Y(1:ny1, iy2, 1:ny3) = Yout(1:ny1,1:ny3)
!	   ----------------------------------------
	   do iy3=1,ny3
	   do iy1=1,ny1
	      Y(iy1,iy2,iy3) = Yout(iy1,iy3)
	   enddo
	   enddo

	enddo

	deallocate( Xin )
	deallocate( Yout )
	deallocate( A_t )

	deallocate( BCX )

	return
	end subroutine kron3

	subroutine kron2( ny1, ny2, nx1,nx2,
     &           A, lda, B, ldb, X, ldx, Y, ldy )
	implicit none
	integer, intent(in) :: ny1,ny2, nx1,nx2
	integer, intent(in) :: lda,ldb,ldx,ldy

	complex*16, dimension(lda,*), intent(in) :: A
	complex*16, dimension(ldb,*), intent(in) :: B
	complex*16, dimension(ldx,*), intent(in) :: X
	complex*16, dimension(ldy,*), intent(inout) :: Y
!
!	compute Y = kron(A,B) * X
!
!	Y = B * X * transpose(A)
!
!	Y(ny1,ny2) = B(ny2,nx1) * X(nx1,nx2) *
!                                transpose( A(ny2,nx2) )
!

!	---------------
!	local variables
!	---------------
	complex*16, dimension(:,:), allocatable :: BX, XA, A_t
	integer :: size_BX, size_XA
	integer :: flops_BX, flops_XA
	logical :: use_BX
	integer :: mm,nn,kk, ld1,ld2,ld3
	integer :: i,j
	complex*16 :: alpha,beta

	size_BX = ny1 * nx2
	size_XA = nx1 * ny2

	flops_BX = nx1*ny1*nx2 + nx2*ny1*ny2
	flops_XA = nx2*nx1*ny2 + nx1*ny1*nx2

	use_BX = (size_BX.lt.size_XA) .or.
     &      ((size_BX.eq.size_XA).and.(flops_BX.lt.flops_XA))

	if (use_BX) then
!	----------------------------------
!	compute as Y = (B*X) * tranpose(A)
!	BX(1:ny1,1:nx2) = B(1:ny1,1:nx1) * X(1:nx1, 1:nx2)
!	----------------------------------
	allocate( BX(ny1,nx2) )

	if (use_gemm) then
	   mm = ny1
	   nn = nx2
	   kk = nx1
	   ld1 = size(B,1)
	   ld2 = size(X,1)
	   ld3 = size(BX,1)
	   alpha = 1.0d0
	   beta = 0.0d0
	   call zgemm( 'N','N', mm,nn,kk,
     &		alpha, B,ld1, X, ld2, beta, BX, ld3 )

!	  ------------------------------------------
!	  Y(1:ny1,1:ny2) = matmul( BX(1:ny1, 1:nx2),
!               transpose( A(1:ny2,1:nx2) ) )
!	  ------------------------------------------

	   mm = ny1
	   nn = ny2
	   kk = nx2
	   ld1 = size(BX,1)
	   ld2 = size(A,1)
	   ld3 = size(Y,1)
	   alpha = 1.0d0
	   beta = 0.0d0

	   call zgemm('N', 'T', mm,nn,kk,
     &          alpha, BX, ld1, A, ld2, beta, Y, ld3 )

	else
	  BX(1:ny1,1:nx2) = matmul( B(1:ny1,1:nx1),
     &         X(1:nx1,1:nx2))

	  allocate( A_t(1:nx2,1:ny2) )
	  do j=1,ny2
	  do i=1,nx2
	    A_t(i,j) = A(j,i)
	  enddo
	  enddo
	  Y(1:ny1,1:ny2) = matmul( BX(1:ny1, 1:nx2),
     &         A_t(1:nx2,1:ny2) )

	  deallocate( A_t )
	endif

	deallocate( BX )

	else
!	-----------------------------------
!	compute as Y = B * (X*transpose(A))
!	-----------------------------------
	allocate( XA(nx1,ny2) )

	if (use_gemm) then
	   mm = nx1
	   nn = ny2
	   kk = nx2
	   ld1 = size(X,1)
	   ld2 = size(A,1)
	   ld3 = size(XA,1)
	   alpha = 1.0d0
	   beta = 0.0d0

	   call zgemm( 'N', 'T', mm,nn,kk,
     &           alpha, X, ld1, A, ld2, beta, XA, ld3 )

	   mm = ny1
	   nn = ny2
	   kk = nx1
	   ld1 = size(B,1)
	   ld2 = size(XA,1)
	   ld3 = size(Y,1)
	   alpha = 1.0d0
	   beta = 0.0d0

	   call zgemm( 'N','N', mm,nn,kk,
     &		alpha, B,ld1, XA, ld2, beta, Y, ld3 )

	else

	  allocate( A_t(1:nx2,1:ny2) )
	  do j=1,ny2
	  do i=1,nx2
	    A_t(i,j) = A(j,i)
	  enddo
	  enddo

	  XA(1:nx1,1:ny2) = matmul( X(1:nx1,1:nx2),
     &        A_t(1:nx2,1:ny2)  )

	  deallocate( A_t )

	  Y(1:ny1,1:ny2) = matmul( B(1:ny1,1:nx1),
     &                    XA(1:nx1, 1:ny2) )
	endif

	deallocate( XA )
	endif

	return
	end subroutine kron2

	end module kron3_mod


    program demo_mod
    implicit none
         print *, mod(17,3)           ! yields 2
         print *, mod(17.5,5.5)       ! yields 1.0
         print *, mod(17.5d0,5.5d0)   ! yields 1.0d0
         print *, mod(17.5d0,5.5d0)   ! yields 1.0d0

         print *, mod(-17,3)          ! yields -2
         print *, mod(-17.5,5.5)      ! yields -1.0
         print *, mod(-17.5d0,5.5d0)  ! yields -1.0d0
         print *, mod(-17.5d0,5.5d0)  ! yields -1.0d0

         print *, mod(17,-3)          ! yields 2
         print *, mod(17.5,-5.5)      ! yields 1.0
         print *, mod(17.5d0,-5.5d0)  ! yields 1.0d0
         print *, mod(17.5d0,-5.5d0)  ! yields 1.0d0
    end program demo_mod


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ellu_bbt2chol( n, B, G )

!  Given an n x n matrix B, compute the lower
!  Cholesky triangle  G:   G * G^T = B * B^T

!  The Cholesky triangle G is returned in full format.

!  Method: B = L * Q;  so that B * B^T = L * L^T; and so G = L.
!  Note: the upper triangle of G is NOT set to zero.

implicit none
integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n
real(k_dp), intent(in)  :: B(n,n)
real(k_dp), intent(out) :: G(n,n)

integer    :: j, info, lwork
real(k_dp) :: tau(n), work(10+n*(10+n))

!  perform LQ factorization: B = G*Q
lwork = 10+n*(10+n)
G = B
call dgelqf( n, n, G, n, tau, work, lwork, info )

if( info /=0 ) then
   write(0,*)'ell_bbt2cholf: dgelqf failed, info = ', info
   stop
endif

!  ensure that diagonal elements are non-negative
do j = 1, n
   if( G(j,j) < 0.d0 ) G(j:n,j) = -G(j:n,j)
end do

return
end subroutine ellu_bbt2chol


c     # -------------------------------------------------------
c     # adapted from the C-function 'fclaw2d_map_c2m_disk'
c     # in fclaw2d_map.c (C. Burstedde)
c     # -------------------------------------------------------

      subroutine mapc2m_squareddisk(blockno,xc,yc,xp,yp,zp,alpha)
      implicit none

      double precision xc,yc,xp,yp,zp
      double precision alpha
      integer blockno
      double precision xc1, yc1

      double precision pi, pi2
      common /compi/ pi, pi2

      if (blockno .eq. 2) then
         xp = (2*xc - 1)*alpha/sqrt(2.d0);
         yp = (2*yc - 1)*alpha/sqrt(2.d0);
      else
         if (blockno .eq. 0) then
            xc1 = xc
            yc1 = 1.d0-yc
            call squareddisk_help(alpha,xc1,yc1,xp,yp)
            yp = -yp
         elseif (blockno .eq. 1) then
            xc1 = yc
            yc1 = 1.d0-xc
            call squareddisk_help(alpha,xc1,yc1,yp,xp)
            xp = -xp
         elseif (blockno .eq. 3) then
            xc1 = yc
            yc1 = xc
            call squareddisk_help(alpha,xc1,yc1,yp,xp)
         elseif (blockno .eq. 4) then
            xc1 = xc
            yc1 = yc
            call squareddisk_help(alpha,xc1,yc1,xp,yp)
         else
            write(6,*) 'mapc2m_squareddisk : Invalid block number'
            stop
         endif
      endif
      zp = 0

      end

      subroutine squareddisk_help(alpha,xi,eta,x,y)
      implicit none

      double precision xi, eta, x,y
      double precision alpha
      double precision R, tau, xi_prime

      double precision pi, pi2

      common /compi/ pi, pi2

c     # Original R - might be smoother
      R = alpha**(1-eta)

c     # This seems to lead to more uniform cells
c      R = (1-alpha)*eta + alpha

      tau = tan(0.5d0*pi*(xi - 0.5d0))
      xi_prime = 2.d0*(1.d0 - eta)*(xi-0.5d0)+eta*tau

c      y = R/sqrt(1.d0 + eta*tau**2 + (1.d0-eta))

      y = R/sqrt(2.d0 + eta*(tau**2 - 1))
      x = y*xi_prime

      end


c
c ---------------------------------------------------------------
c
      subroutine weights(p,xc,yc,totxx,totxy,totyy,wt,area,points,
     .                   hx,hy,k)

      implicit double precision (a-h,o-z)
      dimension  p(10,2), wt(24)
      dimension  subar(20), points(24,2)
      dimension  txx(20),txy(20),tyy(20)
c
c     # compute integral over cell p of quadratic terms
c     # shifted by centroid.  have already computed
c     # centroid (xc,yc) of the polygon p.
c
      index = 1
      do 3 i = 1, 24
        wt(i) = 0.d0
 3    continue

      x0 = xc
      y0 = yc
      do 100 i=2,20
         if (p(i,1) .eq. -11) then
           if (i.eq.2) then
             write(6,*) 'degenerate polygon in weights'
             stop
           endif
         go to 200
         endif

c        # Compute centroid of triangle with vertices 1, i-1, and i
c
         x1 = p(i-1,1)
         y1 = p(i-1,2)
         x2 = p(i,1)
         y2 = p(i,2)

c
c        # compute area:
c
         subar(i) = 0.5d0 * ((y0+y1)*(x1-x0) + (y1+y2)*(x2-x1)
     &                     + (y2+y0)*(x0-x2))
c
c        # use 3rd order approximation of average of midpoints
c
         xmid = (x0+x1)/2.d0
         ymid = (y0+y1)/2.d0
         points(index,1)  = xmid
         points(index,2)  = ymid
         wt(index) = wt(index) + 1.d0/3.d0*subar(i)/area
         fnxx1 = (xmid-xc)*(xmid-xc)
         fnyy1 = (ymid-yc)*(ymid-yc)
         fnxy1 = (xmid-xc)*(ymid-yc)

         xmid = (x2+x1)/2.d0
         ymid = (y2+y1)/2.d0
         index = index + 1
         points(index,1)  = xmid
         points(index,2)  = ymid
         wt(index) = wt(index) + 1.d0/3.d0*subar(i)/area
         fnxx2 = (xmid-xc)*(xmid-xc)
         fnyy2 = (ymid-yc)*(ymid-yc)
         fnxy2 = (xmid-xc)*(ymid-yc)

         xmid = (x0+x2)/2.d0
         ymid = (y0+y2)/2.d0
         index = index + 1
         points(index,1)  = xmid
         points(index,2)  = ymid
         wt(index) = wt(index) + 1.d0/3.d0*subar(i)/area
         fnxx3 = (xmid-xc)*(xmid-xc)
         fnyy3 = (ymid-yc)*(ymid-yc)
         fnxy3 = (xmid-xc)*(ymid-yc)

         txx(i-1)  = .5d0*subar(i)*(fnxx1 + fnxx2 + fnxx3) / 3.d0
         txy(i-1)  =      subar(i)*(fnxy1 + fnxy2 + fnxy3) / 3.d0
         tyy(i-1)  = .5d0*subar(i)*(fnyy1 + fnyy2 + fnyy3) / 3.d0

c
  100    continue
      write(6,*) 'error in weights:  too many vertices'
      stop
c
  200 continue
c
c
c   compute final integrals of quadratic terms
      totxx   = 0.d0
      totxy   = 0.d0
      totyy   = 0.d0
      checkar = 0.d0
      do  230 j = 2, i-1
         totxx = totxx + txx(j-1)
         totxy = totxy + txy(j-1)
         totyy = totyy + tyy(j-1)
         checkar = checkar + subar(j)
 230   continue
      totxx = totxx / area
      totxy = totxy / area
      totyy = totyy / area
      if (dabs(checkar-area)/area .gt. 1.e-9) then
          write(6,*) 'areas differ: ', checkar,area
      endif
c
      return
      end


      SUBROUTINE FORINT (NGP,IMON,FMON,FOR12,FOR1)

C--   Aux. routine FORINT : linear interpolation of monthly-mean forcing

      REAL FOR12(NGP,*), FOR1(NGP)

      IF (FMON.LE.0.5) THEN
        IMON2 = IMON-1
        IF (IMON.EQ.1) IMON2 = 12
        WMON = 0.5-FMON
      ELSE
        IMON2 = IMON+1
        IF (IMON.EQ.12) IMON2 = 1
        WMON = FMON-0.5
      ENDIF

      DO J=1,NGP
        FOR1(J) = FOR12(J,IMON)+WMON*(FOR12(J,IMON2)-FOR12(J,IMON))
      ENDDO
C--
      RETURN
      END

      subroutine FORIN5 (ngp,imon,fmon,for12,for1)

C--   Aux. routine FORIN5 : non-linear, mean-conserving interpolation
C--                         of monthly-mean forcing fields

      real for12(ngp,12), for1(ngp)

      im2 = imon-2
      im1 = imon-1
      ip1 = imon+1
      ip2 = imon+2

      if (im2.lt.1)  im2 = im2+12
      if (im1.lt.1)  im1 = im1+12
      if (ip1.gt.12) ip1 = ip1-12
      if (ip2.gt.12) ip2 = ip2-12

      c0 = 1./12.
      t0 = c0*fmon
      t1 = c0*(1.-fmon)
      t2 = 0.25*fmon*(1-fmon)

      wm2 =        -t1   +t2
      wm1 =  -c0 +8*t1 -6*t2
      w0  = 7*c0      +10*t2
      wp1 =  -c0 +8*t0 -6*t2
      wp2 =        -t0   +t2

      do j=1,ngp
        for1(j) = wm2*for12(j,im2)+wm1*for12(j,im1)
     &           + w0*for12(j,imon)
     &           +wp1*for12(j,ip1)+wp2*for12(j,ip2)
      enddo

      return
      end


      subroutine grd2utm(e,n,ix,iy,box,nx,ny)
! convert the grid number ix, iy to utm
! given the four corners of the rectangle in box
! and the total global grid number nx, ny
! input: ix, iy
! output: e, n

! 2006-11-27
! Po Chen, Lamont

      implicit none
      integer ix, iy, nx, ny
      double precision, dimension(4,2) :: box
      double precision lx, ly, e, n, x, y, a, b, c, d, dx, dy, l
!      print*, 'box corners:'
!      print*, box(1,1),box(1,2)
!      print*, box(2,1),box(2,2)
!      print*, box(3,1),box(3,2)
!      print*, box(4,1),box(4,2)
      lx=sqrt((box(4,1)-box(1,1))**2+(box(4,2)-box(1,2))**2)
      ly=sqrt((box(2,1)-box(1,1))**2+(box(2,2)-box(1,2))**2)
      dx=lx/(nx-1)
      dy=ly/(ny-1)
      x=dble(ix-1)*dx
      y=dble(iy-1)*dy
      l=sqrt(x**2+y**2)

      a=(lx/(box(4,2)-box(1,2)))/((box(4,1)-box(1,1))/(box(4,2)-box(1,2))-(box(2,1)-box(1,1))/(box(2,2)-box(1,2)))
      b=-a*(box(2,1)-box(1,1))/(box(2,2)-box(1,2))
      c=(ly/(box(2,2)-box(1,2)))/((box(2,1)-box(1,1))/(box(2,2)-box(1,2))-(box(4,1)-box(1,1))/(box(4,2)-box(1,2)))
      d=-c*(box(4,1)-box(1,1))/(box(4,2)-box(1,2))

      e=a*x+c*y+box(1,1)
      n=b*x+d*y+box(1,2)
      return
      end subroutine


c     Fortran translation (Heh!) of test1 in quadpack-tests.lisp.
      program test1
      double precision alpha
      integer keyval(3)
      data keyval/1,3,6/

      print *, 'Test integral 1'
      print *
      print *, ' integrate(x^alpha*log(1/x), x, 0, 1)'
      print *, '   = (1+alpha)^(-2)'
      print *
      do 10 key = 1,3
         print *, 'QAG, key = ', keyval(key)
         print 9000
         do 20 alpha = -0.9d0, 0d0, 0.1d0
            call quad(alpha, keyval(key))
   20    continue
         do 30 alpha = 0.2d0, 2.6d0, 0.2d0
            call quad(alpha, keyval(key))
   30    continue
   10 continue
 9000 format('alpha   est result              est abserr             nev
     &al    ier   true answer            true abs err')
      end
      double precision function soln(alpha)
      double precision alpha
      soln = (1 + alpha)**(-2)
      return
      end

      double precision function f(x)
      double precision x
      double precision alfa
      common /param/ alfa
      f = x**alfa * log(1/x)
      return
      end

      subroutine quad(alpha, key)
      parameter (limit = 200, lenw = 4*limit)
      integer limit, lenw

      double precision alpha
      integer key
      double precision alfa
      common /param/alfa

      integer iwork(limit)
      double precision work(lenw)
      double precision f, soln
      external f

      double precision result, abserr
      integer neval, ier, last

      alfa = alpha

      call dqag(f, 0d0, 1d0, 0d0, 1d-8, key, result, abserr, neval,
     $     ier, limit, lenw, last, iwork, work)
      print 9000, alpha, result, abserr, neval, ier, soln(alpha),
     $     abs(soln(alpha) - result)
      return
 9000 format(f5.1, 2(2x, 1pe22.15), 2(2x,i5), 2x, 1pe22.15, 1x, 1pe10.3)
      end


real,           dimension(2,6) :: a
complex,        dimension(2,4) :: b
double complex, dimension(2,3) :: c

real sdot, sdsdot, snrm2, sasum, scnrm2, scasum, slamch
real slange, clange, slansy, clansy
complex cdotu, cdotc
double complex zdotu, zdotc

a = transpose(reshape([1,3,2,4,3,5, 6,4,5,3,4,2],[6,2]))
b = transpose(reshape([(1,2),(3,4),(5,6),(7,8), (8,1),(7,2),(6,3),(5,4)],[4,2]))
c = transpose(reshape([(3,2),(2,4),(1,6), (4,6),(5,4),(6,2)],[3,2]))

write(*,*) 'If the return value interface is fixed, none of these values will'
write(*,*) 'be zero, nor will they be nonsensically large or small. On the'
write(*,*) 'other hand, if the translation is incorrect, it is more likely'
write(*,*) 'that this program will carsh.'
write(*,*) ' '

write(*,*) sdot(6,a(1,:),1,a(2,:),1), sdsdot(6,2.0,a(1,:),1,a(2,:),1), &
	snrm2(6,a(1,:),1), sasum(6,a(2,:),1)
write(*,*) cdotu(4,b(1,:),1,b(2,:),1), cdotc(4,b(1,:),1,b(2,:),1)
write(*,*) scnrm2(4,b(1,:),1), scasum(4,b(2,:),1)
write(*,*) zdotu(3,c(1,:),1,c(2,:),1)
write(*,*) zdotc(3,c(1,:),1,c(2,:),1)

write(*,*) slange('F',2,6,a,2,a),clange('F',2,4,b,2,b), &
	slansy('F','L',2,a,2,a),clansy('F','L',2,a,2,a)

write(*,*) ' '
write(*,*) 'These are the machine constants generated by SLAMCH. We expect'
write(*,*) 'some of them to be small (E-08,E-38).'
write(*,*) ' '

write(*,*) slamch('E'),slamch('S'),slamch('B')
write(*,*) slamch('P'),slamch('R'),slamch('M')
write(*,*) slamch('U'),slamch('L'),slamch('O')

end


module gauss_quad

   ! <doc>
   !  Utilities for Gaussian quadrature.
   !  This module provides subroutines to obtain zeros and weights of
   !  Gauss-Legendre and Gauss-Laguerre quadrature rules.
   ! </doc>

   implicit none

   public :: get_legendre_grids_from_cheb
   public :: get_laguerre_grids

   private

   logical :: debug = .false.
   logical :: weight_roundoff_correction = .false.

   integer, parameter :: qp = selected_real_kind(33, 4931)

contains

   subroutine get_legendre_grids_from_cheb(x1, x2, zero, wgt)

      ! <doc>
      !  returns Legendre zeros and weights in the given interval [x1,x2].
      !  The order is determined from the size of the array 'zero'.
      ! </doc>

      use constants, only: pi => dpi
      real, intent(in) :: x1, x2
      real, dimension(:), intent(out) :: zero, wgt
      integer :: i, nn, nh
      double precision :: xold, xnew, pold, pnew
      double precision, dimension(:), allocatable :: zz, ww

      nn = size(zero)
      nh = (nn + 1) / 2
      allocate (zz(nh))
      allocate (ww(nh))

      ! search zero from 1 to 0 using chebyshev grid points
      ! this is O(nn^2) operations
      xold = cos(pi / (2 * (nn + 1)))
      pold = legendre_p(nn, xold)
      do i = 1, nh
         xnew = cos(pi * (2 * i + 1) / (2 * (nn + 1)))
         pnew = legendre_p(nn, xnew)
         call find_zero_bisect_newton(nn, xold, xnew, pold, pnew, zz(i))
         xold = xnew
         pold = pnew
      end do
      ! invert them to give zeros in (-1,0]
      zz(1:nn / 2) = -zz(1:nn / 2)

      ! weight from formula
!    ww = dble(2.0) / (dble(1.0) - zz**2) / legendre_pp(nn,zz,dble(0.0))**2
      ww = dble(2.0) / (dble(1.0) - zz**2) / legendre_pp(nn, zz)**2

      ! rescale (x2 may be smaller than x1)
      zero(1:nh) = real(zz * (x2 - x1) + (x1 + x2)) / 2.0
      zero(nh + 1:nn) = real(zz(nn / 2:1:-1) * (x1 - x2) + (x1 + x2)) / 2.0
      wgt(1:nh) = real(ww * abs(x2 - x1) / 2.0)
      wgt(nh + 1:nn) = wgt(nn / 2:1:-1)

      deallocate (zz)
      deallocate (ww)

      ! roundoff correction
!!$    if (abs(sum(wgt)/abs(x2-x1)) - 1.0 > epsilon(wgt)) then
!!$       print *, 'roundoff correction occurred'
      if (weight_roundoff_correction) then
         if (mod(nn, 2) == 0) then
            wgt(nh) = abs(x2 - x1) / 2.0 - sum(wgt(1:nh - 1))
            wgt(nh + 1) = wgt(nh)
         else
            wgt(nh) = abs(x2 - x1) - sum(wgt(1:nh - 1)) * 2.0
         end if
      end if

      call check_legendre_zero(x1, x2, zero)
      call check_legendre_weights(abs(x2 - x1), wgt)

      if (debug) then
         print *, 'get_legendre_grids_from_cheb: sum of weights = ', sum(wgt)
         print *, 'get_legendre_grids_from_cheb: section length = ', abs(x2 - x1)
      end if

   end subroutine get_legendre_grids_from_cheb

   subroutine find_zero_bisect_newton(n, xold, xnew, pold, pnew, zz)

      use file_utils, only: error_unit
      integer, intent(in) :: n
      double precision, intent(in) :: xold, xnew, pold, pnew
!    real, intent (in) :: eps
      double precision, intent(out) :: zz
      integer :: i, maxit = 100
      real :: eps
      double precision :: x1, x2, p1, p2, pz

      ! <doc>
      !  eps is declared as real on purpose.
      !  We don't require higher order precision for convergence test
      !  because of a performance reason. The following definition means
      !  eps is a geometric mean of the machine-epsilons in real and double
      !  precisions.
      !  (note that real/double are promoted to double/double or double/quad
      !  depending on the compiler.)
      !
      !  [same applies to eps in find_zero below.]
      ! </doc>

      eps = sqrt(epsilon(eps) * epsilon(x1)) * 2.0
      i = 0
      x1 = xold
      x2 = xnew
      p1 = pold
      p2 = pnew

      if (debug) write (*, '(4f10.5)') x1, p1, x2, p2

      ! bisection
      do i = 1, 5
         zz = (x1 + x2) * dble(.5)
         pz = legendre_p(n, zz)
         if (abs(pz) <= epsilon(pz)) return
         if (pz * p1 < 0.0) then
            p2 = pz; x2 = zz
         else
            p1 = pz; x1 = zz
         end if
         if (debug) write (*, '(4f10.5)') x1, p1, x2, p2
      end do

      if (debug) print *, 'finished bisection'

      ! newton-raphson
      if (zz == x1) x1 = x2
!    do while (abs(zz/x1-1.0) > eps)
      do i = 1, maxit
         x1 = zz
         p1 = legendre_p(n, x1)
!       zz = x1 - p1 / legendre_pp(n,x1,p1)
         zz = x1 - p1 / legendre_pp(n, x1)
         pz = legendre_p(n, zz)
         if (debug) write (*, '(4f10.5)') zz, pz, x1, p1
         if (min(abs(zz / x1 - 1.0), abs(pz)) < eps) exit
      end do

      if (i == maxit + 1) write (error_unit(), *) &
           & 'WARNING: too many iterations in get_legendre_grids'

      if (debug) stop

   end subroutine find_zero_bisect_newton

   elemental function legendre_p(n, x)

      integer, intent(in) :: n
      double precision, intent(in) :: x
      integer :: k
      double precision :: p, p1, p2, legendre_p

      select case (n)
      case (0)
         legendre_p = dble(1.0)
      case (1)
         legendre_p = x
      case default
         p1 = x
         p2 = dble(1.0)
         do k = 2, n
            p = ((2 * k - 1) * x * p1 - (k - 1) * p2) / k
            p2 = p1
            p1 = p
         end do
         legendre_p = p
      end select

   end function legendre_p

!  elemental function legendre_pp (n, x, p1)
   elemental function legendre_pp(n, x)

      integer, intent(in) :: n
      double precision, intent(in) :: x
!    double precision, intent (in), optional :: p1
      double precision :: legendre_pp

!    if (present(p1)) then
!       legendre_pp = n * ( x * p1 - legendre_p(n-1,x) ) &
!            / (x**2 - dble(1.0))
!    else
      legendre_pp = n * (x * legendre_p(n, x) - legendre_p(n - 1, x)) &
                    / (x**2 - dble(1.0))
!    end if

   end function legendre_pp

   subroutine check_legendre_zero(x0, x1, zero)

      use mp, only: mp_abort
      use file_utils, only: error_unit
      real, intent(in) :: x0, x1
      real, dimension(:), intent(in) :: zero
      logical :: error = .false.
      integer :: nn, nh
      real :: xx, xmin, xmax
      real, dimension(:), allocatable :: zz

      nn = size(zero)
      nh = (nn + 1) / 2
      error = .false.
      xmin = min(x0, x1)
      xmax = max(x0, x1)
      allocate (zz(nn))
      zz = zero
      if (zz(1) > zz(nn)) zz(1:nn) = zero(nn:1:-1)
      if (zz(1) < xmin .or. zz(nn) > xmax) then
         write (error_unit(), *) 'ERROR in legendre: grid out of range'
         error = .true.
      end if

      if (nn == 1) then
         if (abs(2.0 * zz(1) / (xmin + xmax) - 1.0) > epsilon(0.0)) then
            write (error_unit(), '("ERROR in legendre: zz(1)= ", f20.15)') zz(1)
            error = .true.
         end if
      else
         ! check if distances at the edge: This suffices for nn<=3
         if (zz(2) - zz(1) <= zz(1) - xmin .or. zz(nn) - zz(nn - 1) <= xmax - zz(nn)) then
            write (error_unit(), *) 'ERROR in legendre: wrong distance at edge'
            error = .true.
         end if
         ! check distances at the center: The above and this suffices for nn=4
         if (mod(nn, 2) == 0 .and. nn >= 4) then
            if (zz(nh + 1) - zz(nh) <= zz(nh) - zz(nh - 1) .or. &
                zz(nh + 1) - zz(nh) <= zz(nh + 2) - zz(nh + 1)) then
               write (error_unit(), *) &
                    & 'ERROR in legendre: wrong distance at center'
               error = .true.
            end if
         end if
         if (nn >= 5) then
            ! check if distances are increasing toward center
            ! lower half
            if (any(zz(3:nh) - zz(2:nh - 1) <= zz(2:nh - 1) - zz(1:nh - 2))) then
               write (error_unit(), *) 'ERROR in legendre: distance decreasing toward center'
               error = .true.
            end if
            ! upper half
            ! The separate use of nh and nn/2 are intentionally so that they
            ! both work for even and odd cases
            if (any(zz(nn / 2 + 2:nn - 1) - zz(nn / 2 + 1:nn - 2) &
                 & <= zz(nn / 2 + 3:nn) - zz(nn / 2 + 2:nn - 1))) then
               write (error_unit(), *) 'ERROR in legendre: distance decreasing toward center'
               error = .true.
            end if
         end if

      end if

      ! check if legendre_p(n, zero(i)) are close enough to zero
      if (debug) then
         xx = maxval(abs(real(legendre_p(nn, &
                                         dble((zz(:) - xmin) / (xmax - xmin) * 2.0 - 1.0)))))
         if (xx / nn**2 > epsilon(xx)) then
            write (error_unit(), *) 'WARNING in legendre: maxval(n,zz(:))= ', xx
            ! Do not stop as it is mostly a minor issue
         end if
      end if

      if (error) call mp_abort('STOP in check_legendre_zero')

   end subroutine check_legendre_zero

!  subroutine check_legendre_weights (norm, wgt, eps)
   subroutine check_legendre_weights(norm, wgt)

      use mp, only: mp_abort
      use file_utils, only: error_unit
      real, intent(in) :: norm!, eps
      real, dimension(:), intent(in) :: wgt
      logical :: error = .false.
      integer :: n, nh
      real :: s

      n = size(wgt)
      error = .false.
      nh = (n + 1) / 2

      ! check if weights are all positive
      if (any(wgt < 0.)) then
         write (error_unit(), *) 'ERROR in legendre: weights got negative'
         error = .true.
      end if

      if (n >= 2) then
         ! check symmetry of weights
         if (any(abs(wgt(n:n + 1 - n / 2:-1) / wgt(1:n / 2) - 1.0) > epsilon(wgt))) then
            write (error_unit(), *) 'WARNING in legendre: symmetry of weights broken'
            error = .true.
         end if

         ! check if weights are increasing toward center
         if (n >= 3) then
            if (any(wgt(2:nh) <= wgt(1:nh - 1))) then
               write (error_unit(), *) 'ERROR in legendre: weights decreasing toward center'
               error = .true.
            end if
         end if
      end if

      ! check if their sum is close enough to normalized value
      if (debug) then
!       s = sum(wgt)
         s = sum(dble(wgt)) ! ignore roundoff error arising from 8-byte summation
         if (abs(norm / s - 1.0) > epsilon(s)) then
            write (error_unit(), *) 'WARNING in legendre: weights summation incorrect:', &
                 & size(wgt), s / norm - 1.0
            ! Do not stop as it is mostly a minor issue
         end if
      end if

      if (error) call mp_abort('STOP in check_legendre_weights')

   end subroutine check_legendre_weights

   subroutine get_laguerre_grids(zero, wgt)

      ! <doc>
      !  returns Laguerre zeros and weights.
      !  The order is determined from the size of the array 'zero'.
      ! </doc>

      use mp, only: mp_abort
      use file_utils, only: error_unit
      real, dimension(:), intent(out) :: zero
      real, dimension(:), intent(out) :: wgt
      logical :: error = .false.
      integer :: i, j, n, nzero
      real(kind=qp) :: x, delx, pold, pnew
      !double precision, dimension (:), allocatable :: zz
      real(kind=qp), dimension(:), allocatable :: zz
      double precision :: eps

      n = size(zero)
      allocate (zz(n))
      zz = 0.0

      eps = epsilon(zero(1)) * dble(4.0)

      if (n > 180) then
         write (error_unit(), *) 'ERROR: can''t get so many laguerre grid points'
         write (error_unit(), *) 'ERROR: size(zero)= ', n
         error = .true.
      end if

      ! search zero from 0 to xmax using evenly spaced grid points
      if (n == 1) then

         zero(1) = 1.0
         wgt(1) = 1.0
         return

      else

         nzero = 0
         pold = real(laguerre_l(n, real(0.0, qp)), qp)
         delx = 0.001
         do i = 1, 1000      ! up to x=1
            x = delx * i
!          print*, x
            pnew = real(laguerre_l(n, x), qp)
!          if (pold*pnew < epsilon(0.0)) then
            if (pold * pnew < 0.0) then
               nzero = nzero + 1
               call find_zero(n, eps, x - delx, x, pold, pnew, zz(nzero))
            end if
            pold = pnew
         end do

         do j = 0, 3
            delx = delx * 10.
            do i = 1, 900
               x = delx * (i + 100)
!             print*, x
               pnew = laguerre_l(n, x)
               if (pold * pnew < 0.0) then
                  nzero = nzero + 1
                  call find_zero(n, eps, x - delx, x, pold, pnew, zz(nzero))
               end if
               if (nzero == n) exit
               pold = pnew
            end do
            if (nzero == n) exit
         end do

      end if

      zero = real(zz, kind(zero(1)))
      wgt = real(zz / (n + 1)**2 / laguerre_l(n + 1, zz)**2, kind(wgt(1)))

      deallocate (zz)

      ! roundoff correction
      if (weight_roundoff_correction) then
         i = sum(maxloc(wgt))
         wgt(i) = 1.0 - sum(wgt(1:i - 1)) - sum(wgt(i + 1:n))
      end if

      ! check number of found zeros
      if (nzero < n) then
         write (error_unit(), *) 'ERROR in laguerre: didn''t find all zeros'
         do i = 1, n
            write (error_unit(), *) i, zero(i)
         end do
         stop
      end if

      call check_laguerre_zeros(zero)
      call check_laguerre_weights(wgt, eps=1.0e-7)

      if (error) call mp_abort('STOP in get_laguerre_grids')

   end subroutine get_laguerre_grids

   subroutine find_zero(n, eps, xold, xnew, pold, pnew, zz)

      use file_utils, only: error_unit
      integer, intent(in) :: n
      double precision, intent(in) :: eps
      real(kind=qp), intent(in) :: xold, xnew, pold, pnew
      !double precision, intent (out) :: zz
      real(kind=qp), intent(out) :: zz
      integer :: i, maxit = 100
      real(kind=qp) :: x1, x2, p1, p2, pz

      ! <doc>
      !  eps is declared as real on purpose.
      !  [see comment in find_zero_bisect_newton above.]
      ! </doc>

      x1 = xold
      x2 = xnew
      p1 = pold
      p2 = pnew

      if (debug) write (*, '(a,4es15.5e3)') 'initial ', x1, p1, x2, p2

      ! bisection
      do i = 1, maxit
         zz = (x1 + x2) * 0.5
         pz = laguerre_l(n, zz)
         if (abs(pz) <= eps) return
         if (pz * p1 < 0.) then
            p2 = pz; x2 = zz
         else
            p1 = pz; x1 = zz
         end if
         if (debug) write (*, '(a,6es25.15e3)') 'bisection ', x1, p1, x2, p2, pz, eps
      end do

      if (i == maxit + 1) then
         ! newton-raphson
         if (zz == x1) x1 = x2
         do i = 1, maxit
            x1 = zz
            p1 = dble(laguerre_l(n, x1))
            zz = x1 - p1 / dble(laguerre_lp(n, x1))
            pz = dble(laguerre_l(n, zz))
            if (debug) write (*, '(a,5es25.15e3)') &
               'newton ', zz, pz, x1, p1, eps
            if (min(abs(zz / x1 - dble(1.0)), abs(pz)) < eps) exit
         end do

         if (i == maxit + 1) then
            write (error_unit(), *) &
                 & 'WARNING: too many iterations in get_laguerre_grids'

            stop 11
         end if
      end if

   end subroutine find_zero

   elemental function laguerre_l(n, x)

      integer, intent(in) :: n
      real(kind=qp), intent(in) :: x
      integer :: k
!    double precision :: laguerre_l, p, p1, p2
      real(kind=qp) :: laguerre_l, p, p1, p2

      p1 = dble(1.0) - x
      p2 = dble(1.0)

      if (n == 0) then
         laguerre_l = p2
         return
      else if (n == 1) then
         laguerre_l = p1
         return
      end if

      do k = 2, n
         p = ((dble(2.0) * k - dble(1.0) - x) * p1 - (k - dble(1.0)) * p2) / k
         p2 = p1
         p1 = p
      end do

      laguerre_l = p

   end function laguerre_l

   elemental function laguerre_lp(n, x)

      integer, intent(in) :: n
      real(kind=qp), intent(in) :: x
      real(kind=qp) :: laguerre_lp

      laguerre_lp = n * (laguerre_l(n, x) - laguerre_l(n - 1, x)) / x

   end function laguerre_lp

   subroutine check_laguerre_zeros(zero)

      use file_utils, only: error_unit
      use mp, only: mp_abort
      real, dimension(:), intent(in) :: zero
      logical :: error = .false.
      integer :: i, n

      n = size(zero)

      ! check positiveness
      if (any(zero <= 0.0)) then
         write (error_unit(), *) 'ERROR in laguerre: grid not positive'
         error = .true.
      end if

      ! check alignment
      if (any(zero(2:n) - zero(1:n - 1) < 0.0)) then
         write (error_unit(), *) 'ERROR in laguerre: wrong alignment'
         error = .true.
      end if

      ! check distances are increasing
      do i = 1, n - 2
         if (zero(i + 1) - zero(i) > zero(i + 2) - zero(i + 1)) then
            write (error_unit(), *) 'ERROR in laguerre: distances are decreasing at i= ', i
            error = .true.
         end if
      end do

      if (error) call mp_abort('STOP in check_laguerre_zeros')

   end subroutine check_laguerre_zeros

   subroutine check_laguerre_weights(wgt, eps)

      use file_utils, only: error_unit
      use mp, only: mp_abort
      real, intent(in) :: eps
      real, dimension(:), intent(in) :: wgt
      logical :: error = .false.
      integer :: imax, n
      real :: s

      n = size(wgt)

      ! check if weights are all positive
      if (any(wgt <= 0.0)) then
         write (error_unit(), *) 'ERROR in laguerre: weights are not positive at n =', n
         error = .true.
      end if

      ! check if there is a single maximum
      imax = sum(maxloc(wgt))
      if (any(wgt(1:imax - 1) > wgt(2:imax))) then
         write (error_unit(), *) 'ERROR in laguerre: weights decreasing before maximum'
         error = .true.
      end if
      if (any(wgt(imax:n - 1) < wgt(imax + 1:n))) then
         write (error_unit(), *) 'ERROR in laguerre: weights increasing after maximum'
         error = .true.
      end if

      ! check if their sum is close enough to normalized value
      if (debug) then
         s = sum(dble(wgt))
         if (abs(s - 1.0) > eps) then
            write (error_unit(), *) 'WARNING in laguerre: weights summation incorrect:', &
               size(wgt), s
            ! Do not stop as it is mostly a minor issue
         end if
      end if

      if (error) call mp_abort('STOP error in check_laguerre_weights')

   end subroutine check_laguerre_weights

end module gauss_quad


*DECK C9LN2R
      COMPLEX FUNCTION C9LN2R (Z)
C***BEGIN PROLOGUE  C9LN2R
C***SUBSIDIARY
C***PURPOSE  Evaluate LOG(1+Z) from second order relative accuracy so
C            that  LOG(1+Z) = Z - Z**2/2 + Z**3*C9LN2R(Z).
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4B
C***TYPE      COMPLEX (R9LN2R-S, D9LN2R-D, C9LN2R-C)
C***KEYWORDS  ELEMENTARY FUNCTIONS, FNLIB, LOGARITHM, SECOND ORDER
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Evaluate  LOG(1+Z)  from 2-nd order with relative error accuracy so
C that     LOG(1+Z) = Z - Z**2/2 + Z**3*C9LN2R(Z).
C
C Now  LOG(1+Z) = 0.5*LOG(1+2*X+ABS(Z)**2) + I*CARG(1+Z),
C where X = REAL(Z)  and  Y = AIMAG(Z).
C We find
C     Z**3 * C9LN2R(Z) = -X*ABS(Z)**2 - 0.25*ABS(Z)**4
C        + (2*X+ABS(Z)**2)**3 * R9LN2R(2*X+ABS(Z)**2)
C        + I * (CARG(1+Z) + (X-1)*Y)
C The imaginary part must be evaluated carefully as
C     (ATAN(Y/(1+X)) - Y/(1+X)) + Y/(1+X) - (1-X)*Y
C       = (Y/(1+X))**3 * R9ATN1(Y/(1+X)) + X**2*Y/(1+X)
C
C Now we divide through by Z**3 carefully.  Write
C     1/Z**3 = (X-I*Y)/ABS(Z)**3 * (1/ABS(Z)**3)
C then   C9LN2R(Z) = ((X-I*Y)/ABS(Z))**3 * (-X/ABS(Z) - ABS(Z)/4
C        + 0.5*((2*X+ABS(Z)**2)/ABS(Z))**3 * R9LN2R(2*X+ABS(Z)**2)
C        + I*Y/(ABS(Z)*(1+X)) * ((X/ABS(Z))**2 +
C          + (Y/(ABS(Z)*(1+X)))**2 * R9ATN1(Y/(1+X)) ) )
C
C If we let  XZ = X/ABS(Z)  and  YZ = Y/ABS(Z)  we may write
C     C9LN2R(Z) = (XZ-I*YZ)**3 * (-XZ - ABS(Z)/4
C        + 0.5*(2*XZ+ABS(Z))**3 * R9LN2R(2*X+ABS(Z)**2)
C        + I*YZ/(1+X) * (XZ**2 + (YZ/(1+X))**2*R9ATN1(Y/(1+X)) ))
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R9ATN1, R9LN2R
C***REVISION HISTORY  (YYMMDD)
C   780401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  C9LN2R
      COMPLEX Z
C***FIRST EXECUTABLE STATEMENT  C9LN2R
      X = REAL (Z)
      Y = AIMAG (Z)
C
      CABSZ = ABS(Z)
      IF (CABSZ.GT.0.8125) GO TO 20
C
      C9LN2R = CMPLX (1.0/3.0, 0.0)
      IF (CABSZ.EQ.0.0) RETURN
C
      XZ = X/CABSZ
      YZ = Y/CABSZ
C
      ARG = 2.0*XZ + CABSZ
      RPART = 0.5*ARG**3*R9LN2R(CABSZ*ARG) - XZ - 0.25*CABSZ
      Y1X = YZ/(1.0+X)
      AIPART = Y1X * (XZ**2 + Y1X**2*R9ATN1(CABSZ*Y1X) )
C
      C9LN2R = CMPLX(XZ,-YZ)**3 * CMPLX(RPART,AIPART)
      RETURN
C
 20   C9LN2R = (LOG(1.0+Z) - Z*(1.0-0.5*Z)) / Z**3
      RETURN
C
      END


c
c-----------------------------------------------------------------------
c
      subroutine channelPtInit(xcen,ycen,rho,u,v,p)
      implicit double precision(a-h,o-z)
c
c     # For the point (x,y), compute the true solution at this point
c

       rho = ycen**2
       !rho = ycen**2 - 0.1d0*xcen**2 + 5.d0 + 2.d0*xcen*ycen
       !rho = ycen - 0.1d0*xcen + 0.5d0
       !rho = ycen + 0.5d0
       u = 0.d0
       v = 0.d0
       p = 1.d0

       return
       end
c
c-----------------------------------------------------------------------
c
      subroutine channelAvgInit(poly,xcen,ycen,rho,u,v,p)

      implicit double precision(a-h,o-z)
      dimension poly(10,2)
      dimension q(4,3), qcent(20,4), area(20), celltot(4)
c
c     # For the centroid (x,y), compute the true cell avg.  To
c      compute cell average (to 3rd order). decompose
c      polygon into triangles, with centroid always
c      a vertex.  use approx. that cell avg. is
c      average of the function values on the 3 sides

      do 10 kside = 2, 20
         if (poly(kside,1) .eq. -11) then
            kend = kside - 2
            go to 99
         endif

         xst = poly(kside-1,1)
         yst = poly(kside-1,2)

         xend = poly(kside,1)
         yend = poly(kside,2)

         xavg = (xst+xend)/2.d0
         yavg = (yst+yend)/2.d0
         call channelPtInit(xavg,yavg,rho1,u1,v1,p1)

         xavg = (xend+xcen)/2.d0
         yavg = (yend+ycen)/2.d0
         call channelPtInit(xavg,yavg,rho2,u2,v2,p2)

         xavg = (xst+xcen)/2.d0
         yavg = (yst+ycen)/2.d0
         call channelPtInit(xavg,yavg,rho3,u3,v3,p3)
c
c     compute area of triangle
         area(kside-1) = .5d0*((yst+ycen)*(xcen-xst) +
     &        (ycen+yend)*(xend-xcen)+(yend+yst)*(xst-xend))
            qcent(kside-1,1) = (rho1+rho2+rho3)/3.d0
            qcent(kside-1,2) = (u1+u2+u3)/3.d0
            qcent(kside-1,3) = (v1+v2+v3)/3.d0
            qcent(kside-1,4) = (p1+p2+p3)/3.d0

 11      continue
 10   continue

 99   continue

         totar   = 0.d0
         celltot = 0.d0
         do 12 k = 1, kend
            celltot(1) = area(k)*qcent(k,1) + celltot(1)
            celltot(2) = area(k)*qcent(k,2) + celltot(2)
            celltot(3) = area(k)*qcent(k,3) + celltot(3)
            celltot(4) = area(k)*qcent(k,4) + celltot(4)
            totar   = totar + area(k)
 12      continue

      rho = celltot(1) / totar
      u   = celltot(2) / totar
      v   = celltot(3) / totar
      p   = celltot(4) / totar

      return
      end


module make_analytic_solution_module

  use amrex_error_module
  use amrex_constants_module
  use base_state_geometry_module, only: center
  use probin_module, only: ambient_h, ambient_dens, &
       t0, peak_h, diffusion_coefficient
  use meth_params_module, only: prob_lo

  implicit none

  private

contains

  subroutine make_analytic_solution(lo, hi, solution, s_lo, s_hi, dx, time) &
       bind(C, name="make_analytic_solution")

    integer, intent(in) :: lo(3), hi(3), s_lo(3), s_hi(3)
    double precision, intent(inout) :: solution(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3))
    double precision, intent(in   ) :: dx(3)
    double precision, intent(in   ), value :: time

    integer :: n, i, j, k
    double precision :: x, y, dist2

    solution(s_lo(1):s_hi(1),s_lo(2):s_hi(2),s_lo(3):s_hi(3)) = ZERO

    do k = lo(3), hi(3)

       do j = lo(2), hi(2)

          y = prob_lo(2) + (dble(j)+HALF) * dx(2) - center(2)

          do i = lo(1), hi(1)

             x = prob_lo(1) + (dble(i)+HALF) * dx(1) - center(1)

             dist2 = x**2 + y**2

             solution(i,j,k) = f(time,dist2)

          enddo
       enddo
    enddo

  end subroutine make_analytic_solution

  function f(t,x) result(r)
    double precision :: t, x
    double precision :: r

    r = (peak_h - ambient_h) * (t0 / (t+t0)) * &
         dexp(-x / (FOUR * diffusion_coefficient * (t+t0))) + ambient_h

  end function f

end module make_analytic_solution_module