module nonlinear_transport

implicit none

contains

  pure real(8) function exact4(x)

    real(8), intent(in) :: x

    exact4 = -1.0d0 + sqrt(4.0d0-(8.0d0/3.0d0)*x-x*x*x/3.0d0)

  end function exact4

  pure real(8) function exact3(x)

    real(8), intent(in) :: x

    exact3 = -1.0d0 + sqrt(4.0d0-2.0d0*x-x*x)

  end function exact3

  pure real(8) function exact2(x)

    real(8), intent(in) :: x

    exact2 = -1.0d0 + sqrt(4.0d0-3.0d0*x)

  end function exact2

  ! Model problem to solve
  pure subroutine assemble_residual_jacobian(sparse, npts, phi, Q, V, R)

    logical, intent(in) :: sparse
    integer, intent(in) :: npts
    real(8), intent(in) :: phi(:) ! current state
    real(8), intent(in) :: Q(:) ! source

    real(8), intent(inout) :: V(:,:) ! jacbian
    real(8), intent(inout) :: R(:) ! residual

    real(8), parameter :: a = 0.0d0, b = 1.0d0 ! bound of domain
    real(8), parameter :: L = 1.0d0

    real(8), parameter :: phi0 = 1.0d0
    real(8), parameter :: phiN = 0.0d0

    ! Local variables
    real(8) :: aa, bb, cc
    real(8) :: h
    integer :: m, n, i, j

    m = npts
    n = npts

    ! Mesh spacing
    h = (b-a)/dble(npts+1)

    ! Assemble the Residual for supplied source
    R = 0.0d0

    ! First node
    aa = 1.0d0 + phi(1)
    bb = phi0 - 2.0d0*(1.0d0+phi(1)) - phi(2)
    cc = 1.0d0 - phi(1) + 2.0d0*phi(2)
    R(1) = 0.0d0 + &
         & - ( phi(2) - 2.0d0*phi(1) + phi0 &
         & + phi(2)*phi(2) &
         & - phi(2)*phi(1) &
         & - phi(1)*phi(1) &
         & + phi(1)*phi0 &
         & + h*h*Q(1)/0.1d0 )

    ! Interior nodes
    do i = 2, m-1
       aa = 1.0d0 + phi(i)
       bb = phi(i-1) - 2.0d0*(1.0d0+phi(i)) - phi(i+1)
       cc = 1.0d0 - phi(i) + 2.0d0*phi(i+1)
       R(i) = -(phi(i+1) - 2.0d0*phi(i) + phi(i-1) &
            & + phi(i+1)*phi(i+1) &
            & - phi(i+1)*phi(i) &
            & - phi(i)*phi(i) &
            & + phi(i)*phi(i-1) &
            & + h*h*Q(i)/0.1d0)
    end do

    ! Last node
    aa = 1.0d0 + phi(npts)
    bb = phi(npts-1) - 2.0d0*(1.0d0+phi(npts)) - phiN
    cc = 1.0d0 - phi(npts) + 2.0d0*phiN
    R(npts) = 0.0 + &
         & - ( phiN - 2.0d0*phi(npts) + phi(npts-1) &
         & + phiN*phiN &
         & - phiN*phi(npts) &
         & - phi(npts)*phi(npts) &
         & + phi(npts)*phi(npts-1) &
         & + h*h*Q(npts)/0.1d0)

    ! Assemble the jacobian
    V = 0.0d0

    if (sparse .eqv. .false.) then

       do i = 1, m

          ! Create matrix coefficients
          if (i.eq.1) then
             ! First node
             aa = 1.0d0 + phi(1)
             bb = phi0 - 2.0d0*(1.0d0+phi(1)) - phi(2)
             cc = 1.0d0 - phi(1) + 2.0d0*phi(2)
          else if (i.eq.npts) then
             ! Last node
             aa = 1.0d0 + phi(npts)
             bb = phi(npts-1) - 2.0d0*(1.0d0+phi(npts)) - phiN
             cc = 1.0d0 - phi(npts) + 2.0d0*phiN
          else
             ! Interior nodes
             aa = 1.0d0 + phi(i)
             bb = phi(i-1) - 2.0d0*(1.0d0+phi(i)) - phi(i+1)
             cc = 1.0d0 - phi(i) + 2.0d0*phi(i+1)
          end if

          do j = 1, n
             if (i .eq. j-1) then
                ! upper diagonal
                V(i,j) = cc
             else if (i .eq. j) then
                ! diagonal
                V(i,i) = bb
             else if (i .eq. j+1) then
                ! lower diagonal
                V(i,j) = aa
             else
             end if
          end do
       end do

    else

       do concurrent(i=1:n)

          if (i.eq.1) then

             ! First node
             aa = 1.0d0 + phi(1)
             bb = phi0 - 2.0d0*(1.0d0+phi(1)) - phi(2)
             cc = 1.0d0 - phi(1) + 2.0d0*phi(2)

             V(i,:) = [0.0d0, bb, cc]

          else if (i.eq.npts) then

             ! Last node
             aa = 1.0d0 + phi(npts)
             bb = phi(npts-1) - 2.0d0*(1.0d0+phi(npts)) - phiN
             cc = 1.0d0 - phi(npts) + 2.0d0*phiN

             V(i,:) = [aa, bb, 0.0d0]

          else

             ! Interior nodes
             aa = 1.0d0 + phi(i)
             bb = phi(i-1) - 2.0d0*(1.0d0+phi(i)) - phi(i+1)
             cc = 1.0d0 - phi(i) + 2.0d0*phi(i+1)

             V(i,:) = [aa, bb, cc]

          end if

       end do

    end if

  end subroutine assemble_residual_jacobian

end module nonlinear_transport


program P17626
    implicit none
    integer :: n, i, j, sq
    integer, dimension(0:50000) :: save
    read *, n
    save(0) = 0
    do i = 1, n
        save(i) = i
        j = 1
        sq = 1
        do while (sq <= i)
            save(i) = min(save(i), save(i - sq) + 1)
            j = j + 1
            sq = j * j
        end do
    end do
    write (*, '(I0)') save(n)
end program P17626


      SUBROUTINE SRCVAL (X, Y, RC, IERR)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>>   2001-07-16 SRCVAL Krogh  Change -1.0 to -1.e0.
c>>   1996-03-30 SRCVAL Krogh  Added external statement.
C>>   1995-11-17 SRCVAL Krogh  Converted SFTRAN to Fortran 77.
C>>   1994-10-19 SRCVAL Krogh  Changes to use M77CON
C>>   1991-10-31 SRCVAL WV Snyder JPL Incorporate changes from Carlson
C>>   1990-12-20 SRCVAL WV Snyder JPL Convert from NSWC for Math 77.
C
C     THIS SUBROUTINE COMPUTES THE ELEMENTARY INTEGRAL
C
C     RC(X,Y) = INTEGRAL FROM ZERO TO INFINITY OF
C
C                         -1/2     -1
C               (1/2)(T+X)    (T+Y)  DT,
C
C     WHERE X IS NONNEGATIVE AND Y IS NONZERO.  IF Y IS NEGATIVE,
C     THE CAUCHY PRINCIPAL VALUE IS COMPUTED BY USING A PRELIMI-
C     NARY TRANSFORMATION TO MAKE Y POSITIVE; SEE EQUATION (2.12)
C     OF THE SECOND REFERENCE BELOW.  WHEN Y IS POSITIVE, THE
C     DUPULICATION THEOREM IS ITERATED UNTIL THE VARIABLES ARE
C     NEARLY EQUAL, AND THE FUNCTION IS THEN EXPANDED IN TAYLOR
C     SERIES TO FIFTH ORDER.  LOGARITHMIC, INVERSE CIRCULAR, AND
C     INVERSE HYPERBOLIC FUNCTIONS ARE EXPRESSED IN TERMS OF RC
C     BY EQUATIONS (4.9)-(4.13) OF THE SECOND REFERENCE BELOW.
C
C     REFERENCES: B. C. CARLSON AND E. M. NOTIS, ALGORITHMS FOR
C     INCOMPLETE ELLIPTIC INTEGRALS, ACM TRANSACTIONS ON MATHEMA-
C     TICAL SOFTWARE, 7 (1981), 398-403;
C     B. C. CARLSON, COMPUTING ELLIPTIC INTEGRALS BY DUPLICATION,
C     NUMER. MATH. 33 (1979), 1-16.
C     AUTHORS: B. C. CARLSON AND ELAINE M. NOTIS, AMES LABORATORY-
C     DOE, IOWA STATE UNIVERSITY, AMES, IA 50011, AND R. L. PEXTON,
C     LAWRENCE LIVERMORE NATIONAL LABORATORY, LIVERMORE, CA 94550.
C     AUG. 1, 1979, REVISED SEPT. 1, 1987.
C
C     CHECK VALUES: RC(0,1/4) = RC(1/16,1/8) = PI,
C                   RC(9/4,2) = LN(2),
C                   RC(1/4,-2) = LN(2)/3.
C     CHECK BY ADDITION THEOREM: RC(X,X+Z) + RC(Y,Y+Z) = RC(0,Z),
C     WHERE X, Y, AND Z ARE POSITIVE AND  X * Y = Z * Z.
C
C    *****     Formal Arguments     ***********************************
C
C          LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS.
C     LOLIM IS NOT LESS THAN THE MACHINE MINIMUM MULTIPLIED BY 5.
C     UPLIM IS NOT GREATER THAN THE MACHINE MAXIMUM DIVIDED BY 5.
C
C     INPUT ...
C
C     X AND Y ARE THE VARIABLES IN THE INTEGRAL RC(X,Y).
C
C     OUTPUT ...
C
C     RC IS THE VALUE OF THE INTEGRAL.
C
C     IERR IS THE RETURN ERROR CODE.
C          0  FOR NORMAL COMPLETION OF THE SUBROUTINE.
C          1  X IS NEGATIVE, OR Y = 0.
C          2  X+ABS(Y) IS TOO SMALL.
C          3  X OR ABS(Y) IS TOO LARGE, OR X + ABS(Y) IS TOO LARGE.
C          4  Y < -2.236/SQRT(LOLIM) AND 0 < X < (LOLIM*UPLIM)**2/25
C
      REAL             X, Y, RC
      INTEGER IERR
C
C--S replaces "?": ?ERM1, ?ERV1, ?RCVAL
C
C     *****     External References     ********************************
C
      EXTERNAL R1MACH
      REAL             R1MACH
C
C     *****     Local Variables     ************************************
C
      REAL             C1,C2,C3,C4,ERRTOL,LAMDA,LOLIM
      REAL             MU,SN,UPLIM,XLU225,XN,Y2236L,YN,W
      PARAMETER (C1 = 3.0e0 / 10.0e0)
      PARAMETER (C2 = 1.0e0 / 7.0e0)
      PARAMETER (C3 = 3.0e0 / 8.0e0)
      PARAMETER (C4 = 9.0e0 / 22.0e0)
      SAVE ERRTOL, LOLIM, UPLIM, XLU225, Y2236L
      DATA LOLIM /-1.0e0/
C
C     ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE.
C     RELATIVE ERROR DUE TO TRUNCATION IS LESS THAN
C     16 * ERRTOL ** 6 / (1 - 2 * ERRTOL).
C
C     SAMPLE CHOICES   ERRTOL   RELATIVE TRUNCATION
C                               ERROR LESS THAN
C                      1.E-3    2.E-17
C                      3.E-3    2.E-14
C                      1.E-2    2.E-11
C                      3.E-2    2.E-8
C                      1.E-1    2.E-5
C
C     We could put in a Newton iteration to solve for ERRTOL in
C     terms of R1MACH(4), but it seems good enough to put
C     ERRTOL = (R1MACH(4)/16.0)**(1.0/6.0)
C
c ----------------------------------------------------------------------
C          WARNING. CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE
C          EXPENSE OF ROBUSTNESS.
c ----------------------------------------------------------------------
C
      IF (X .LT. 0.0e0 .OR. Y .EQ. 0.0e0) THEN
         RC = 0.0e0
         CALL SERM1 ('SRCVAL',1,0,'X < 0 or Y = 0','X',X,',')
         CALL SERV1 ('Y',Y,'.')
         IERR = 1
         RETURN
      END IF
      IF (LOLIM .LT. 0.0e0) THEN
         LOLIM = 5.0e0 * R1MACH(1)
         UPLIM = R1MACH(2) / 5.0e0
         XLU225 = (LOLIM*UPLIM)**2 / 25.0e0
         Y2236L = -2.236e0/SQRT(LOLIM)
         ERRTOL = (R1MACH(4)/16.0e0) ** (1.0e0/6.0e0)
      END IF
      YN = ABS(Y)
      IF (X .GT. UPLIM .OR. YN .GT. UPLIM) THEN
         RC = 0.0e0
       CALL SERM1 ('SRCVAL',3,0,'X > UPLIM or ABS(Y) > UPLIM','X',X,',')
         CALL SERV1 ('Y',Y,',')
         CALL SERV1 ('UPLIM',UPLIM,'.')
         IERR = 3
         RETURN
      END IF
      IF (X + YN .LT. LOLIM) THEN
         RC = 0.0e0
         CALL SERM1 ('SRCVAL',2,0,'X + ABS(Y) < LOLIM','X',X,',')
         CALL SERV1 ('Y',Y,',')
         CALL SERV1 ('LOLIM',LOLIM,'.')
         IERR = 2
         RETURN
      END IF
      IF (X + YN .GT. UPLIM) THEN
         RC = 0.0e0
         CALL SERM1 ('SRCVAL',3,0,'X + ABS(Y) > UPLIM','X',X,',')
         CALL SERV1 ('Y',Y,',')
         CALL SERV1 ('UPLIM',UPLIM,'.')
         IERR = 3
         RETURN
      END IF
      IF (Y.LT.Y2236L .AND. X.GT.0.0e0 .AND. X.LT.XLU225) THEN
         RC = 0.0e0
         CALL SERM1 ('SRCVAL',4,0,
     1      'Y < -2.236/SQRT(LOLIM) AND 0 < X < (LOLIM*UPLIM)**2/25',
     2      'X',X,',')
         CALL SERV1 ('Y',Y,',')
         CALL SERV1 ('LOLIM',LOLIM,',')
         CALL SERV1 ('UPLIM',UPLIM,'.')
         IERR = 4
         RETURN
      END IF
C
      IERR = 0
      IF (Y.GT.0.0e0) THEN
         XN = X
         W = 1.0e0
      ELSE
C        TRANSFORM TO POSITIVE Y
         XN = X - Y
         W = SQRT(X) / SQRT(XN)
      END IF
C
   20 CONTINUE
         MU = (XN + YN + YN) / 3.0e0
         SN = (YN + MU) / MU - 2.0e0
         IF (ABS(SN) .LT. ERRTOL) THEN
            RC = W * (1.0e0+SN*SN*(C1+SN*(C2+SN*(C3+SN*C4)))) / SQRT(MU)
            RETURN
         END IF
         LAMDA = 2.0 * SQRT(XN) * SQRT(YN) + YN
         XN = (XN + LAMDA) * 0.25e0
         YN = (YN + LAMDA) * 0.25e0
      GO TO 20
      END


      SUBROUTINE aniso_euclidean_s(D,x,y,nx,ny,ndx,ndy,cmin,cmax,sr,
     *nsr,symm)

cf2py intent(inplace) D
cf2py integer intent(optional) :: cmin=0
cf2py integer intent(optional) :: cmax=-1
cf2py logical intent(optional) :: symm=0
cf2py intent(hide) nx, ny,ndx,ndy,nsr
cf2py threadsafe

      DOUBLE PRECISION D(nx,ny), x(nx,ndx), y(ny,ndy), sr(nsr)
      INTEGER nx,ny,i,j,k,cmin,cmax,ndx,ndy,nsr
      LOGICAL symm
      DOUBLE PRECISION dist, dev

      if (cmax.EQ.-1) then
          cmax = ny
      end if
      ! print *,nsr,sr(1)

      if(symm) then

        do j=cmin+1,cmax
          D(j,j) = 0.0D0
          do i=1,j-1
            dist = 0.0D0
            do k=1,ndx
              if (k.GT.1) then
                 dev=(x(i,k) - y(j,k))*sr(k-1)
              else
                 dev=(x(i,k) - y(j,k))
              end if
              dist = dist + dev*dev
            enddo
            D(i,j) = dsqrt(dist)
          enddo
        enddo
      else
        do j=cmin+1,cmax
          do i=1,nx
            dist = 0.0D0
            do k=1,ndx
              dev=(x(i,k) - y(j,k))*sr(k)
              dist = dist + dev*dev
            enddo
            D(i,j) = dsqrt(dist)
          enddo
        enddo
      endif
      RETURN
      END


subroutine qinit(meqn,mbc,mx,xlower,dx,q,maux,aux)

    ! Set initial conditions for the q array.

    use geoclaw_module, only: sea_level
    use grid_module, only: xcell

    ! uncomment if any of these needed...
    !use geoclaw_module, only: dry_tolerance, grav

    implicit none

    integer, intent(in) :: meqn,mbc,mx,maux
    real(kind=8), intent(in) :: xlower,dx
    real(kind=8), intent(in) :: aux(maux,1-mbc:mx+mbc)
    real(kind=8), intent(inout) :: q(meqn,1-mbc:mx+mbc)

    !locals
    integer :: i

    real(kind=8) :: eta, width, x0, ampl

    width = 5.d3    ! controls width of Gaussian
    x0 = 0.d3   ! initial location of Gaussian
    ampl = 50.d0  ! amplitude

    do i=1,mx
      eta = ampl * exp(-((xcell(i)-x0)/width)**2)
      q(1,i) = max(sea_level, eta - aux(1,i))
      q(2,i) = 0.d0  !eta*sqrt(grav*q(1,i))  ! right-going

   enddo

end subroutine qinit


subroutine derv(neqn,t,u,ut)
!
! Subroutine derv computes the derivative vector
! of the 2 x 2 ODE problem
!
! Double precision coding is used
implicit double precision(a-h,o-z)
!
! Size the arrays
dimension u(neqn), ut(neqn)
!
! Problem parameters
call par(a,b)
!
! Derivative vector
ut(1)=-a*u(1)+b*u(2)
ut(2)= b*u(1)-a*u(2)
return
!
! End of derv
end


      double precision pi,pisq,pisqo6
      parameter(pi=3.1415926535897932385d0,pisq=pi*pi,pisqo6=pisq/6d0)

      double precision zip,half,one,two,three,four,eight
      parameter(zip=0d0,half=0.5d0,one=1d0,two=2d0)
      parameter(three=3d0,four=4d0,eight=8d0)

      double complex im,impi,czip,cone
      parameter(im=(0d0,1d0),impi=(0d0,3.1415926535897932385d0),
     . czip=(0d0,0d0),cone=(1d0,0d0))


program factorial
    implicit none
    integer, parameter :: n_min = 0, n_max = 10
    integer :: n, factor, product

    do n = n_min, n_max
        product = 1
        do factor = 2, n
            product = product*factor
        end do
        print *, n, product
    end do

end program factorial


    Program zhbevd_example

!     ZHBEVD Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: dznrm2
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen
      Use lapack_interfaces, Only: zhbevd
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Complex (Kind=dp) :: scal
      Integer :: i, ifail, info, j, k, kd, ldab, ldz, liwork, lrwork, lwork, n
      Character (1) :: job, uplo
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: ab(:, :), work(:), z(:, :)
      Real (Kind=dp), Allocatable :: rwork(:), w(:)
      Integer, Allocatable :: iwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, conjg, max, maxloc, min
!     .. Executable Statements ..
      Write (nout, *) 'ZHBEVD Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n, kd
      ldab = n
      ldz = n
      liwork = 5*n + 3
      lrwork = 2*n*n + 5*n + 1
      lwork = 2*n*n
      Allocate (ab(ldab,n), work(lwork), z(ldz,n), rwork(lrwork), w(n), &
        iwork(liwork))

!     Read A from data file

      Read (nin, *) uplo
      If (uplo=='U') Then
        Do i = 1, n
          Read (nin, *)(ab(kd+1+i-j,j), j=i, min(n,i+kd))
        End Do
      Else If (uplo=='L') Then
        Do i = 1, n
          Read (nin, *)(ab(1+i-j,j), j=max(1,i-kd), i)
        End Do
      End If

      Read (nin, *) job

!     Calculate all the eigenvalues and eigenvectors of A
      Call zhbevd(job, uplo, n, kd, ab, ldab, w, z, ldz, work, lwork, rwork, &
        lrwork, iwork, liwork, info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'Failure to converge.'
      Else

!       Print eigenvalues and eigenvectors

        Write (nout, *) 'Eigenvalues'
        Do i = 1, n
          Write (nout, 100) i, w(i)
        End Do
        Write (nout, *)
        Flush (nout)

!       Normalize the eigenvectors, largest element real
        Do i = 1, n
          rwork(1:n) = abs(z(1:n,i))
          k = maxloc(rwork(1:n), 1)
          scal = conjg(z(k,i))/abs(z(k,i))/dznrm2(n, z(1,i), 1)
          z(1:n, i) = z(1:n, i)*scal
        End Do

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_complex_gen('General', ' ', n, n, z, ldz, &
          'Eigenvectors', ifail)

      End If

100   Format (3X, I5, 5X, 2F8.4)
    End Program


program test

    use mpi

    use quadrature, only: trapezoid
    use functions, only: f, fevals_proc, k

    implicit none
    real(kind=8) :: a,b,int_true, int_approx, int_sub, dx_sub
    real(kind=8) :: ab_sub(2)   ! to hold a and b for each subinterval

    integer :: i,j,jj,n_proc,proc_num, num_procs,ierr,n,fevals_total,nsub
    integer :: nextsub, numsent, sender
    integer, dimension(MPI_STATUS_SIZE) :: status

    call MPI_INIT(ierr)
    call MPI_COMM_SIZE(MPI_COMM_WORLD, num_procs, ierr)
    call MPI_COMM_RANK(MPI_COMM_WORLD, proc_num, ierr)

    ! All processes set these values so we don't have to broadcast:
    k = 1.d3   ! functions module variable
    a = 0.d0
    b = 2.d0
    int_true = (b-a) + (b**4 - a**4) / 4.d0 - (1.d0/k) * (cos(k*b) - cos(k*a))
    n = 1000
    !nsub = 4

    if (num_procs == 1) then
        print *, "*** Error: need to use at least two processes"
        go to 999
        endif

    ! Each process keeps track of number of fevals:
    fevals_proc = 0

    if (proc_num==0) then
        int_approx = 0.d0
        print 100, num_procs
100     format("Using ",i3," processes")

        print *, "How many subintervals? "
        read *, nsub

        print 10, int_true
 10     format("true integral: ", es22.14)
        print *, " "  ! blank line
        endif

    call MPI_BARRIER(MPI_COMM_WORLD,ierr) ! wait for process 0 to print
    call MPI_BCAST(nsub, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)

    ! -----------------------------------------
    ! code for Master (Processor 0):
    ! -----------------------------------------

    if (proc_num == 0) then

      numsent = 0 ! keep track of how many subintervals sent

      dx_sub = (b-a) / nsub

      ! send the first batch to get all workers working:
      do j=1,min(num_procs-1, nsub)
        ab_sub(1) = a + (j-1)*dx_sub
        ab_sub(2) = a + j*dx_sub
        call MPI_SEND(ab_sub, 2, MPI_DOUBLE_PRECISION, j, j, &
                      MPI_COMM_WORLD, ierr)
        numsent = numsent + 1
        enddo

      ! as results come back, send out more work...
      ! the variable sender tells who sent back a result and ready for more
      do j=1,nsub
        call MPI_RECV(int_sub, 1, MPI_DOUBLE_PRECISION, &
                        MPI_ANY_SOURCE, MPI_ANY_TAG, &
                        MPI_COMM_WORLD, status, ierr)
        sender = status(MPI_SOURCE)
        jj = status(MPI_TAG)
        ! print *,"+++ int_sub, int_approx: ",int_sub, int_approx
        int_approx = int_approx + int_sub

        if (numsent < nsub) then
            ! still more work to do, the next subinterval will be sent and
            ! this index also used as the tag:
            nextsub = numsent + 1
            ab_sub(1) = a + (nextsub-1)*dx_sub
            ab_sub(2) = a + nextsub*dx_sub

            call MPI_SEND(ab_sub, 2, MPI_DOUBLE_PRECISION, sender, nextsub, &
                          MPI_COMM_WORLD, ierr)
            numsent = numsent + 1
          else
            ! send an empty message with tag=0 to indicate this worker
            ! is done:
            call MPI_SEND(MPI_BOTTOM, 0, MPI_INTEGER, &
                            sender, 0, MPI_COMM_WORLD, ierr)
          endif
         enddo
        endif

    ! -----------------------------------------
    ! code for Workers (Processors 1, 2, ...):
    ! -----------------------------------------
    if (proc_num /= 0) then

        if (proc_num > nsub) go to 99   ! no work expected

        do while (.true.)
            ! repeat until message with tag==0 received...

            call MPI_RECV(ab_sub, 2, MPI_DOUBLE_PRECISION, &
                          0, MPI_ANY_TAG, &
                          MPI_COMM_WORLD, status, ierr)

            j = status(MPI_TAG)   ! this is the subinterval number

            !print 12, proc_num, j       ! for debugging
12          format("+++ Process ",i4,"  received message with tag ",i6)

            if (j==0) go to 99    ! received "done" message

            int_sub = trapezoid(f,ab_sub(1),ab_sub(2),n)

            call MPI_SEND(int_sub, 1, MPI_DOUBLE_PRECISION, &
                        0, j, MPI_COMM_WORLD, ierr)

            enddo
        endif

99  continue   ! might jump to here if finished early

    call MPI_BARRIER(MPI_COMM_WORLD,ierr) ! wait for all process to print

    ! print the number of function evaluations by each thread:
    print 101,  proc_num, fevals_proc
101 format("fevals by Process ",i2,": ",i13)

    call MPI_BARRIER(MPI_COMM_WORLD,ierr) ! wait for all process to print

    call MPI_REDUCE(fevals_proc, fevals_total, 1, MPI_INTEGER, MPI_SUM, 0, &
                    MPI_COMM_WORLD, ierr)

    if (proc_num==0) then
        print 13, nsub*n, int_approx
13      format("Trapezoid approximation with ",i8," total points: ",es22.14)
        print 102, fevals_total
102     format("Total number of fevals: ",i10)
        endif

999 continue
    call MPI_FINALIZE(ierr)

end program test


!-*- mode: compilation; default-directory: "/tmp/" -*-
!Compilation started at Tue May 21 21:43:12
!
!a=./f && make $a && OMP_NUM_THREADS=2 $a 1223334444
!gfortran -std=f2008 -Wall -ffree-form -fall-intrinsics f.f08 -o f
! Shannon entropy of 1223334444 is    1.84643936
!
!Compilation finished at Tue May 21 21:43:12

program shannonEntropy
  implicit none
  integer :: num, L, status
  character(len=2048) :: s
  num = 1
  call get_command_argument(num, s, L, status)
  if ((0 /= status) .or. (L .eq. 0)) then
    write(0,*)'Expected a command line argument with some length.'
  else
    write(6,*)'Shannon entropy of '//(s(1:L))//' is ', se(s(1:L))
  endif

contains
  !     algebra
  !
  ! 2**x = y
  ! x*log(2) = log(y)
  ! x = log(y)/log(2)

  !   NB. The j solution
  !   entropy=:  +/@:-@(* 2&^.)@(#/.~ % #)
  !   entropy '1223334444'
  !1.84644

  real function se(s)
    implicit none
    character(len=*), intent(in) :: s
    integer, dimension(256) :: tallies
    real, dimension(256) :: norm
    tallies = 0
    call TallyKey(s, tallies)
    ! J's #/. works with the set of items in the input.
    ! TallyKey is sufficiently close that, with the merge, gets the correct result.
    norm = tallies / real(len(s))
    se = sum(-(norm*log(merge(1.0, norm, norm .eq. 0))/log(2.0)))
  end function se

  subroutine TallyKey(s, counts)
    character(len=*), intent(in) :: s
    integer, dimension(256), intent(out) :: counts
    integer :: i, j
    counts = 0
    do i=1,len(s)
      j = iachar(s(i:i))
      counts(j) = counts(j) + 1
    end do
  end subroutine TallyKey

end program shannonEntropy


! { dg-do link }
!
! This test checks whether the largest possible
! floating-point number works. That's usually
! REAL(16) -- either because the hardware supports it or
! because of libquadmath. However, it can also be
! REAL(10) or REAL(8)
!
program test_qp
   use iso_fortran_env, only: real_kinds
   implicit none
   integer, parameter :: QP = real_kinds(ubound(real_kinds,dim=1))
   real(QP), parameter :: Z1 = 1,HALF_PI = asin(Z1),PI = HALF_PI+HALF_PI
   real(QP) :: x = 0.124_QP
   complex(QP) :: z = 0.124_QP
   print *, 'kind = ', qp
   print *, x
   print *, PI
   print *, 16*atan(0.2_QP)-4*atan(Z1/239)
   print *, sin(PI)
   print *, cos(HALF_PI)
   print *, asinh(PI)
   print *, erfc(Z1)
   print *, epsilon(x)
   print *, precision(x)
   print *, digits(x)

   print *, z
   print *, PI*cmplx(0.0_qp, 1.0_qp)
! Disable the complex functions as not all "long-double" systems have
! a libm with those C99 functions. (libquadmath had), cf. PR 46584
!   print *, 16*atan(0.2_QP)-4*atan(Z1/239)
!   print *, sin(z)
!   print *, cos(z)
!   print *, sinh(z) ! asinh not implemented in libquadmath, cf. PR 46416
   print *, precision(z)
end program test_qp


!*******************************************************************
!> author: Akira Kageyama
!  date: 2020.01.15
!
!  Fortran定数と数学定数
!
!@note 定数であることが目で見てわかりやすいように全ての文字を
!      大文字で書く。コンパイラには無意味であるので、
!      siとかSiといった変数を使わないように注意。

module constants_m
  implicit none

  ! << f90 constants >>
  integer, parameter :: SI = selected_int_kind(8)   !! 単精度整数種別値
  integer, parameter :: DI = selected_int_kind(16)  !! 倍精度整数種別値
  integer, parameter :: SR = selected_real_kind(6)  !! 単精度実数種別値
  integer, parameter :: DR = selected_real_kind(12) !! 倍精度実数種別値

  ! << Mathematical constants >>
  real(DR), parameter :: PI = 3.1415926535897932_DR !! 円周率
  real(DR), parameter :: TWOPI = PI*2               !! 円周率の2倍
end module constants_m


program realcomp
  ! This program tests and compares the performance
  ! of single and double precision real problems
  !use ifport
  use flips
  use rand

  implicit none

  ! types
  type(flips_s) :: gs
  type(flips_d) :: gd

  ! data matrices
  real(sp), dimension(:,:), allocatable :: amat_s, smat_s, mmat_s
  real(dp), dimension(:,:), allocatable :: amat_d, smat_d, mmat_d

  ! Errors
  real(sp) :: maxerr_s,meanerr_s
  real(dp) :: maxerr_d,meanerr_d

  ! Residuals
  real(sp) :: res_s
  real(dp) :: res_d

  ! Clocks/times
  real(dp) :: cts,cte,ctime1,ctime2
  real(sp) :: wts,wte,wtime1,wtime2

  ! Aux variables
  integer :: ns,n,bs,id = 0

  ! Set random seed
  call set_rand_seed()

  ! Ask size
  write(*,*) 'Give matrix size:'
  read(*,*) ns
  write(*,*) 'Press 1 for binary files.'
  read(*,*) id

  bs = 10

  ! allocate things
  allocate(amat_s(ns,ns),amat_d(ns,ns),smat_s(ns,1),smat_d(ns,1),mmat_s(ns,1),mmat_d(ns,1))

  ! Single pprecision

  ! Create data (theory matrix random, soluton 1's)
  call random_number(amat_s)
  smat_s = 1.0
  mmat_s = matmul(amat_s,smat_s)

  ! init flips
  if (id==1) then
     call flips_init(gs,ns,1,idnum=100,buffersize=bs)

write(*,*) 'FLIPS initialized'

  else
     call flips_init(gs,ns,1,buffersize=bs)
  end if

!write(*,*) 'initialized'

  ! add data and solve with residual
  call cpu_time(cts)
  !call system_clock(wts)
  do n = 1,ns
     call flips_add(gs,1,amat_s(n,:),mmat_s(n,:))

write(*,*) 'FLIPS data row added. n=',n

  end do
!write(*,*) 'data added'
  call flips_solve(gs)

write(*,*) 'FLIPS solved'

!write(*,*) 'solved'
  call cpu_time(cte)
  !call system_clock(wte)
  !wtime1 = wte-wts
  ctime1 = cte-cts

  ! Calculate diagonal of the covariance
  call cpu_time(cts)
  !call system_clock(wts)
  call flips_calc_cov(gs,full=.TRUE.)

write(*,*) 'FLIPS Covariance calculated'

!write(*,*) 'covariance calculated'
  call cpu_time(cte)
  !call system_clock(wte)
  !wtime2 = wte-wts
  ctime2 = cte-cts

  if (id==1) then
     allocate(gs%solmat(ns),gs%cmat(ns))
     call flips_get('solu',gs,gs%solmat)

write(*,*) 'FLIPS solution fetched'

     !call flips_get('cova',gs,gs%cmat)
!write(*,*) 'solution got'
  end if

  ! Errors
  maxerr_s = maxval(abs(smat_s(:,1) - gs%solmat))
  meanerr_s = sum(smat_s(:,1) - gs%solmat)/ns

  ! Print results
  write(*,*) '----------------------------------'
  write(*,*) 'Single precision, size:',ns
  write(*,*) '----------------------------------'
  write(*,*) '  Solution, CPU time:',ctime1
  write(*,*) '          FLOP Count:',gs%fc
  write(*,*) '              GFLOPS:',gs%fc/ctime1/1.0E9
  !write(*,*) 'Solution, wall clock:',wtime1
  write(*,*) 'Covariance, CPU time:',ctime2
  !write(*,*) 'Covariance, wall clock:',wtime2
  write(*,*) '          Mean error:',meanerr_s
  write(*,*) '     Max. abs. error:',maxerr_s
  write(*,*) '            Residual:',gs%residual
  !write(*,*) gs%cmat
  write(*,*) '----------------------------------\n'

  ! Double precision
  ! Create data (theory matrix random, soluton 1's)
  call random_number(amat_d)
  smat_d = 1.0D0
  mmat_d = matmul(amat_d,smat_d)

  ! init flips
  if (id==1) then
     call flips_init(gd,ns,1,idnum=200,buffersize=bs)
  else
     call flips_init(gd,ns,1,buffersize=bs)
  end if
  ! add data and solve with residual
  call cpu_time(cts)
  !call system_clock(wts)
  do n = 1,ns
     call flips_add(gd,1,amat_d(n,:),mmat_d(n,:))
  end do
  call flips_solve(gd)
  call cpu_time(cte)
  !call system_clock(wte)
  !wtime1 = wte-wts
  ctime1 = cte-cts

  ! Calculate diagonal of the covariance
  call cpu_time(cts)
  !call system_clock(wts)
  call flips_calc_cov(gd,full=.TRUE.)
  call cpu_time(cte)
  !call system_clock(wte)
  !wtime2 = wte-wts
  ctime2 = cte-cts

  if (id==1) then
     allocate(gd%solmat(ns))
     call flips_get('solu',gd,gd%solmat)
  end if

  ! Errors
  maxerr_d = maxval(abs(smat_d(:,1) - gd%solmat))
  meanerr_d = sum(smat_d(:,1) - gd%solmat)/ns

  ! Print results
  write(*,*) '----------------------------------'
  write(*,*) 'Double precision, size:',ns
  write(*,*) '----------------------------------'
  write(*,*) '  Solution, CPU time:',ctime1
  write(*,*) '          FLOP Count:',gd%fc
  write(*,*) '              GFLOPS:',gd%fc/ctime1/1.0D9
  !write(*,*) 'Solution, wall clock:',wtime1
  write(*,*) 'Covariance, CPU time:',ctime2
  !write(*,*) 'Covariance, wall clock:',wtime2
  write(*,*) '          Mean error:',meanerr_d
  write(*,*) '     Max. abs. error:',maxerr_d
  write(*,*) '            Residual:',gd%residual
  !write(*,*) gd%solmat(1:5)
  write(*,*) '----------------------------------\n'

end program realcomp


	FUNCTION PR_PKSS  ( pspd )
C************************************************************************
C* PR_PKSS								*
C*									*
C* This function computes SPED from PSPD.  PSPD is in the form DDFFF,	*
C* where DD is the wind direction in tens of degrees, and FFF is	*
C* either the wind speed or the wind speed plus 500, depending on	*
C* the unit digit of direction rounded to the nearest 5 degrees.	*
C* The following equation is used:					*
C*									*
C*            SPED = MOD ( INT (PSPD) , 500 )				*
C*									*
C* REAL PR_PKSS  ( PSPD )						*
C*									*
C* Input parameters:							*
C*	PSPD		REAL		Packed speed and direction	*
C*									*
C* Output parameters:							*
C*	PR_PKSS		REAL		Wind speed in knots		*
C**									*
C* Log:									*
C* I. Graffman/CSC	8/83	Original source code			*
C* G. Huffman/GSC	8/88	Documentation and modulus fix		*
C************************************************************************
        INCLUDE  'GEMPRM.PRM'
        INCLUDE  'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing values.
C
	IF  ( ERMISS (pspd) )  THEN
	    PR_PKSS = RMISSD
C
C*      Formally, SPED is MOD ( PSPD, 1000 ), with 500 subtracted off if
C*      needed, but 1000 is a multiple of 500, so it is done in 1 step.
C
	  ELSE
	    PR_PKSS = MOD ( IFIX (pspd), 500 )
	END IF
C*
	RETURN
	END


SUBROUTINE CHEGVX_F95( A, B, W, ITYPE, JOBZ, UPLO, VL, VU, IL, IU, &
     &  M, IFAIL, ABSTOL, INFO )
!  .. USE STATEMENTS ..
      USE LA_PRECISION, ONLY: WP => SP
      USE LA_AUXMOD, ONLY: ERINFO, LSAME
      USE F77_LAPACK, ONLY: LAMCH_F77 => SLAMCH
      USE F77_LAPACK, ONLY: HEGVX_F77 => LA_HEGVX, ILAENV_F77 => ILAENV
!  .. IMPLICIT STATEMENT ..
      IMPLICIT NONE
!  .. CHARACTER ARGUMENTS ..
      CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: JOBZ, UPLO
!  .. SCALAR ARGUMENTS ..
      INTEGER, INTENT(IN), OPTIONAL :: IL, IU, ITYPE
      INTEGER, INTENT(OUT), OPTIONAL :: INFO, M
      REAL(WP), INTENT(IN), OPTIONAL :: ABSTOL, VL, VU
!  .. ARRAY ARGUMENTS ..
      INTEGER, INTENT(OUT), OPTIONAL, TARGET :: IFAIL(:)
      COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:,:)
      REAL(WP), INTENT(OUT) :: W(:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!    LA_SYGVX and LA_HEGVX compute selected eigenvalues and, optionally,
! the corresponding eigenvectors of generalized eigenvalue problems of
! the form
!      A*z = lambda*B*z, A*B*z = lambda*z,  and  B*A*z = lambda*z,
! where A and B are real symmetric in the case of LA_SYGVX and complex
! Hermitian in the case of LA_HEGVX. In both cases B is positive
! definite. Eigenvalues and eigenvectors can be selected by specifying
! either a range of values or a range of indices for the desired
! eigenvalues.
!
! =========
!
!        SUBROUTINE LA_SYGVX / LA_HEGVX (A, B, W, ITYPE= itype, &
!             JOBZ= jobz, UPLO= uplo, VL= vl, VU= vu, IL= il, &
!             IU= iu, M= m, IFAIL= ifail, ABSTOL= abstol, INFO= info )
!          <type>(<wp>), INTENT(INOUT) :: A(:,:), B(:,:)
!          REAL(<wp>), INTENT(OUT) :: W(:)
!          INTEGER, INTENT(IN), OPTIONAL :: ITYPE
!          CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: JOBZ, UPLO
!          REAL(<wp>), INTENT(IN), OPTIONAL :: VL, VU
!          INTEGER, INTENT(IN), OPTIONAL :: IL, IU
!          INTEGER, INTENT(OUT), OPTIONAL :: M
!          INTEGER, INTENT(OUT), OPTIONAL :: IFAIL(:)
!          REAL(<wp>), INTENT(IN), OPTIONAL :: ABSTOL
!          INTEGER, INTENT(OUT), OPTIONAL :: INFO
!        where
!          <type> ::= REAL | COMPLEX
!          <wp>   ::= KIND(1.0) | KIND(1.0D0)
!
! Arguments
! =========
!
! A      (input/output) REAL or COMPLEX square array, shape (:,:).
!        On entry, the matrix A.
!        If UPLO = 'U', the upper triangular part of A contains the
!        upper triangular part of matrix A. If UPLO = 'L', the lower
!        triangular part of A contains the lower triangular part of
!        matrix A.
!        On exit, if JOBZ = 'V', the first M columns of A contain the
!        orthonormal eigenvectors corresponding to the selected
!        eigenvalues, with the i-th column of A holding the eigenvector
!        associated with the eigenvalue in W(i).
!        The eigenvectors are normalized as follows:
!          if ITYPE = 1 or 2: Z^H * B * Z = I ,
!          if ITYPE = 3: Z^H * B^-1 * Z = I .
!        If an eigenvector fails to converge, then that column of A
!        contains the latest approximation to the eigenvector and the
!        index of the eigenvector is returned in IFAIL.
!        If JOBZ = 'N', then the upper triangle (if UPLO = 'U') or the
!        lower triangle (if UPLO = 'L') of A, including the diagonal, is
!        destroyed.
! B      (input/output) REAL or COMPLEX square array, shape (:,:) with
!        size(B,1) = size(A,1).
!        On entry, the matrix B.
!        If UPLO = 'U', the upper triangular part of B contains the
!        upper triangular part of matrix B. If UPLO = 'L', the lower
!        triangular part of B contains the lower triangular part of
!        matrix B.
!        On exit, the part of B containing the matrix is overwritten by
!        the triangular factor U or L of the Cholesky factorization
!              B = U^H*U or B = L*L^H.
! W      (output) REAL array, shape (:) with size(W) = size(A,1).
!        The first M elements contain the selected eigenvalues in
!        ascending order.
! ITYPE  Optional (input) INTEGER.
!        Specifies the problem type to be solved:
!           = 1: A*z = lambda*B*z
!           = 2: A*B*z = lambda*z
!           = 3: B*A*z = lambda*z
!        Default value: 1.
! JOBZ   Optional (input) CHARACTER(LEN=1).
!           = 'N': Computes eigenvalues only;
!           = 'V': Computes eigenvalues and eigenvectors.
!        Default value: 'N'.
! UPLO   Optional (input) CHARACTER(LEN=1).
!           = 'U': Upper triangles of A and B are stored;
!           = 'L': Lower triangles of A and B are stored.
!        Default value: 'U'.
! VL,VU  Optional (input) REAL.
!        The lower and upper bounds of the interval to be searched for
!        eigenvalues. VL < VU.
!        Default values: VL = -HUGE(<wp>) and VU = HUGE(<wp>), where
!        <wp> ::= KIND(1.0) | KIND(1.0D0).
!        Note: Neither VL nor VU may be present if IL and/or IU is
!        present.
! IL,IU  Optional (input) INTEGER.
!        The indices of the smallest and largest eigenvalues to be
!        returned. The IL-th through IU-th eigenvalues will be found.
!        1<=IL<=IU<=size(A,1).
!        Default values: IL = 1 and IU = size(A,1).
!        Note: Neither IL nor IU may be present if VL and/or VU is
!        present.
!        Note: All eigenvalues are calculated if none of the arguments
!        VL, VU, IL and IU are present.
! M      Optional (output) INTEGER.
!        The total number of eigenvalues found. 0 <= M <= size(A,1).
!        Note: If IL and IU are present then M = IU - IL + 1.
! IFAIL  Optional (output) INTEGER array, shape (:) with size(IFAIL) =
!        size(A,1).
!        If INFO = 0, the first M elements of IFAIL are zero.
!        If INFO > 0, then IFAIL contains the indices of the
!        eigenvectors that failed to converge.
!        Note: IFAIL should be present if JOBZ = 'V'.
! ABSTOL Optional (input) REAL.
!        The absolute error tolerance for the eigenvalues. An approximate
!        eigenvalue is accepted as converged when it is determined to lie
!        in an interval [a,b] of width less than or equal to
!             ABSTOL + EPSILON(1.0_<wp>) * max(| a |, | b |),
!        where <wp> is the working precision. If ABSTOL <= 0, then
!        EPSILON(1.0_<wp>)* ||T||1 will be used in its place, where
!        ||T||1 is the l1 norm of the tridiagonal matrix obtained by
!        reducing the generalized eigenvalue problem to tridiagonal form.
!        Eigenvalues will be computed most accurately when ABSTOL is set
!        to twice the underflow threshold 2 * LA_LAMCH(1.0_<wp>, 'S'),
!        not zero.
!        Default value: 0.0_<wp>.
!        Note: If this routine returns with 0 < INFO <= n, then some
!        eigenvectors did not converge.
!        Try setting ABSTOL to 2 * LA_LAMCH(1.0_<wp>, 'S').
! INFO   Optional (output) INTEGER.
!        = 0: successful exit.
!        < 0: if INFO = -i, the i-th argument had an illegal value.
!        > 0: the algorithm failed to converge or matrix B is not
!        positive definite:
!           <= n: the algorithm failed to converge; if INFO = i, then i
! 	      eigenvectors failed to converge. Their indices are stored
! 	      in array IFAIL.
!           > n: if INFO = n+i, for 1 <= i <= n, then the leading minor
! 	      of order i of B is not positive definite. The
! 	      factorization of B could not be completed and no
! 	      eigenvalues or eigenvectors were computed.
! 	  n is the order of A.
!        If INFO is not present and an error occurs, then the program is
!        terminated with an error message.
!-----------------------------------------------------------------------
!  .. LOCAL PARAMETERS ..
       CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_HEGVX'
       CHARACTER(LEN=6), PARAMETER :: BSNAME = 'ZHETRD'
!  .. LOCAL SCALARS ..
      CHARACTER(LEN=1) :: LJOBZ, LUPLO, LRANGE
      INTEGER :: N, LINFO, LDA, LDZ, LZ, LIL, LIU, LM, LWORK, NB, ISTAT, &
      &     SIFAIL, LDB, LITYPE
      INTEGER, TARGET :: ISTAT1(1)
      REAL(WP) :: LABSTOL, LVL, LVU
!  .. LOCAL ARRAYS ..
      INTEGER, POINTER :: IWORK(:), LIFAIL(:)
      COMPLEX(WP), POINTER :: WORK(:), Z(:,:)
      REAL(WP), POINTER :: RWORK(:)
!  .. INTRINSIC FUNCTIONS ..
      INTRINSIC HUGE, PRESENT, SIZE
!  .. EXECUTABLE STATEMENTS ..
   N = SIZE(A,1); LDA = MAX(1,N); LDB=MAX(1,SIZE(B,1)); LINFO = 0; ISTAT = 0
   IF( PRESENT(ITYPE) )THEN; LITYPE = ITYPE; ELSE; LITYPE = 1; END IF
   IF( PRESENT(IFAIL) )THEN; SIFAIL = SIZE(IFAIL);ELSE; SIFAIL = N; END IF
   IF( PRESENT(JOBZ ) )THEN; LJOBZ=JOBZ; ELSE; LJOBZ = 'N'; ENDIF
   IF( PRESENT(UPLO) ) THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; END IF
   IF( PRESENT(VL) )THEN; LVL = VL; ELSE; LVL = -HUGE(LVL); ENDIF
   IF( PRESENT(VU) )THEN;  LVU = VU; ELSE; LVU = HUGE(LVU); ENDIF
   IF( PRESENT(IL) )THEN; LIL = IL; ELSE; LIL = 1; ENDIF
   IF( PRESENT(IU) )THEN; LIU = IU; ELSE; LIU = N; ENDIF
!  .. TEST THE ARGUMENTS
   IF( PRESENT(VL) .OR. PRESENT(VU) )THEN ; LRANGE = 'V'; LM=N
   ELSE IF( PRESENT(IL) .OR. PRESENT(IU) )THEN ; LRANGE = 'I'; LM=LIU-LIL+1
   ELSE ; LRANGE = 'A'; LM=N; END IF
   IF( SIZE( A, 2 ) /= N .OR. N < 0 )THEN; LINFO = -1
   ELSE IF (SIZE (B, 2) /= N ) THEN; LINFO = -2
   ELSE IF( SIZE( W ) /= N )THEN;  LINFO = -3
   ELSE IF( LITYPE < 1 .OR. LITYPE > 3 )THEN; LINFO = -4
   ELSE IF( .NOT.LSAME(LJOBZ,'V') .AND. .NOT.LSAME(LJOBZ,'N') )THEN; LINFO = -5
   ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -6
   ELSE IF( LVU < LVL )THEN ; LINFO = -7
   ELSE IF( (PRESENT(VL) .OR. PRESENT(VU)) .AND. &
            (PRESENT(IL) .OR. PRESENT(IU)) )THEN; LINFO = -8
   ELSE IF( LSAME(LRANGE, 'I') .AND. ( LIU < MIN( N, LIL ) .OR. LIU>N))THEN; LINFO = -9
   ELSE IF( N < LIU )THEN; LINFO = -10
   ELSE IF( SIFAIL /= N )THEN; LINFO = -12
   ELSE IF( N > 0 )THEN

    IF(LSAME(LJOBZ, 'V')) THEN
       LDZ = MAX(1,N); LZ=LM
    ELSE
       LDZ = 1; LZ=1
    ENDIF
    IF( PRESENT(IFAIL) )THEN; LIFAIL => IFAIL
    ELSE; ALLOCATE( LIFAIL(N), STAT=ISTAT ); END IF
!     .. DETERMINE THE WORKSPACE
      NB = ILAENV_F77( 1, BSNAME, LUPLO, N, -1, -1, -1 )
      IF( NB < 5 .OR. NB >= N )THEN
         NB = 5
      END IF
      LWORK = N*(3+NB)

      ALLOCATE(Z(LDZ, LZ), STAT=ISTAT)
      IF (ISTAT /= 0) LINFO = -100

      ALLOCATE(IWORK(10*5*N), WORK(10*LWORK), RWORK(7*N), STAT=ISTAT)
      IF( ISTAT /= 0 )THEN
         DEALLOCATE(IWORK, WORK, STAT=ISTAT1(1))
         LWORK = N*8*10
         ALLOCATE(IWORK(10*5*N), WORK(LWORK), RWORK(7 *N), STAT=ISTAT)
         IF( ISTAT /= 0 ) THEN
            LINFO = - 100
         ELSE
            CALL ERINFO( -200, SRNAME, LINFO )
         ENDIF
      END IF
      IF( LINFO == 0 )THEN
         IF( PRESENT(ABSTOL) )THEN; LABSTOL = ABSTOL
         ELSE; LABSTOL = 2*LAMCH_F77('Safe minimum');  ENDIF
!     .. CALL LAPACK77 ROUTINE
	    CALL HEGVX_F77( LITYPE, LJOBZ, LRANGE, LUPLO, N, A, LDA, B, &
     &         LDB, LVL, LVU, LIL, LIU, LABSTOL, LM, W, Z, LDZ, WORK, &
     &         LWORK, RWORK, IWORK, LIFAIL, LINFO )

         IF( PRESENT(M) ) M = LM
	 IF (LSAME(LJOBZ,'V'))  A(1:LDZ, 1:LM)=Z(1:LDZ, 1:LM)
      END IF
      DEALLOCATE(IWORK, WORK, RWORK, STAT=ISTAT1(1))
      DEALLOCATE(Z, STAT=ISTAT)
      END IF
      CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
END SUBROUTINE CHEGVX_F95


      SUBROUTINE DF01MD( SICO, N, DT, A, DWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the sine transform or cosine transform of a real
C     signal.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     SICO    CHARACTER*1
C             Indicates whether the sine transform or cosine transform
C             is to be computed as follows:
C             = 'S':  The sine transform is computed;
C             = 'C':  The cosine transform is computed.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of samples.  N must be a power of 2 plus 1.
C             N >= 5.
C
C     DT      (input) DOUBLE PRECISION
C             The sampling time of the signal.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (N)
C             On entry, this array must contain the signal to be
C             processed.
C             On exit, this array contains either the sine transform, if
C             SICO = 'S', or the cosine transform, if SICO = 'C', of the
C             given signal.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (N+1)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Let A(1), A(2),..., A(N) be a real signal of N samples.
C
C     If SICO = 'S', the routine computes the sine transform of A as
C     follows. First, transform A(i), i = 1,2,...,N, into the complex
C     signal B(i), i = 1,2,...,(N+1)/2, where
C
C        B(1) = -2*A(2),
C        B(i) = {A(2i-2) - A(2i)} - j*A(2i-1) for i = 2,3,...,(N-1)/2,
C        B((N+1)/2) = 2*A(N-1) and j**2 = -1.
C
C     Next, perform a discrete inverse Fourier transform on B(i) by
C     calling SLICOT Library Routine DG01ND, to give the complex signal
C     Z(i), i = 1,2,...,(N-1)/2, from which the real signal C(i) may be
C     obtained as follows:
C
C        C(2i-1) = Re(Z(i)),  C(2i) = Im(Z(i)) for i = 1,2,...,(N-1)/2.
C
C     Finally, compute the sine transform coefficients S ,S ,...,S
C                                                       1  2      N
C     given by
C
C        S  = 0,
C         1
C                {                     [C(k) + C(N+1-k)]     }
C        S  = DT*{[C(k) - C(N+1-k)] - -----------------------},
C         k      {                    [2*sin(pi*(k-1)/(N-1))]}
C
C           for k = 2,3,...,N-1, and
C
C        S = 0.
C         N
C
C     If SICO = 'C', the routine computes the cosine transform of A as
C     follows. First, transform A(i), i = 1,2,...,N, into the complex
C     signal B(i), i = 1,2,...,(N+1)/2, where
C
C        B(1) = 2*A(1),
C        B(i) = 2*A(2i-1) + 2*j*{[A(2i-2) - A(2i)]}
C        for i = 2,3,...,(N-1)/2 and B((N+1)/2) = 2*A(N).
C
C     Next, perform a discrete inverse Fourier transform on B(i) by
C     calling SLICOT Library Routine DG01ND, to give the complex signal
C     Z(i), i = 1,2,...,(N-1)/2, from which the real signal D(i) may be
C     obtained as follows:
C
C        D(2i-1) = Re(Z(i)),  D(2i) = Im(Z(i)) for i = 1,2,...,(N-1)/2.
C
C     Finally, compute the cosine transform coefficients S ,S ,...,S
C                                                         1  2      N
C     given by
C
C        S  = 2*DT*[D(1) + A0],
C         1
C                {                     [D(k) - D(N+1-k)]     }
C        S  = DT*{[D(k) + D(N+1-k)] - -----------------------},
C         k      {                    [2*sin(pi*(k-1)/(N-1))]}
C
C
C           for k = 2,3,...,N-1, and
C
C        S  = 2*DT*[D(1) - A0],
C         N
C                 (N-1)/2
C     where A0 = 2*SUM   A(2i).
C                  i=1
C
C     REFERENCES
C
C     [1] Rabiner, L.R. and Rader, C.M.
C         Digital Signal Processing.
C         IEEE Press, 1972.
C
C     [2] Oppenheim, A.V. and Schafer, R.W.
C         Discrete-Time Signal Processing.
C         Prentice-Hall Signal Processing Series, 1989.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires 0( N*log(N) ) operations.
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997.
C     Supersedes Release 2.0 routine DF01AD by F. Dumortier, and
C     R.M.C. Dekeyser, State University of Gent, Belgium.
C
C     REVISIONS
C
C     V. Sima, Jan. 2003.
C
C     KEYWORDS
C
C     Digital signal processing, fast Fourier transform, complex
C     signals.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO, FOUR
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
     $                    FOUR = 4.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         SICO
      INTEGER           INFO, N
      DOUBLE PRECISION  DT
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), DWORK(*)
C     .. Local Scalars ..
      LOGICAL           LSICO, LSIG
      INTEGER           I, I2, IND1, IND2, M, MD2
      DOUBLE PRECISION  A0, PIBYM, W1, W2, W3
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DG01ND, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ATAN, DBLE, MOD, SIN
C     .. Executable Statements ..
C
      INFO = 0
      LSICO = LSAME( SICO, 'S' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LSICO .AND. .NOT.LSAME( SICO, 'C' ) ) THEN
         INFO = -1
      ELSE
         M = 0
         IF( N.GT.4 ) THEN
            M = N - 1
C           WHILE ( MOD( M, 2 ).EQ.0 ) DO
   10       CONTINUE
            IF ( MOD( M, 2 ).EQ.0 ) THEN
               M = M/2
               GO TO 10
            END IF
C           END WHILE 10
         END IF
         IF ( M.NE.1 ) INFO = -2
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'DF01MD', -INFO )
         RETURN
      END IF
C
C     Initialisation.
C
      M = N - 1
      MD2 = ( N + 1 )/2
      PIBYM = FOUR*ATAN( ONE )/DBLE( M )
      I2 = 1
      DWORK(MD2+1) = ZERO
      DWORK(2*MD2) = ZERO
C
      IF ( LSICO ) THEN
C
C        Sine transform.
C
         LSIG = .TRUE.
         DWORK(1)  = -TWO*A(2)
         DWORK(MD2) = TWO*A(M)
C
         DO 20 I = 4, M, 2
            I2 = I2 + 1
            DWORK(I2) = A(I-2) - A(I)
            DWORK(MD2+I2) = -A(I-1)
   20    CONTINUE
C
      ELSE
C
C        Cosine transform.
C
         LSIG = .FALSE.
         DWORK(1)   = TWO*A(1)
         DWORK(MD2) = TWO*A(N)
         A0 = A(2)
C
         DO 30 I = 4, M, 2
            I2 = I2 + 1
            DWORK(I2) = TWO*A(I-1)
            DWORK(MD2+I2) = TWO*( A(I-2) - A(I) )
            A0 = A0 + A(I)
   30    CONTINUE
C
         A0 = TWO*A0
      END IF
C
C     Inverse Fourier transform.
C
      CALL DG01ND( 'Inverse', MD2-1, DWORK(1), DWORK(MD2+1), INFO )
C
C     Sine or cosine coefficients.
C
      IF ( LSICO ) THEN
         A(1) = ZERO
         A(N) = ZERO
      ELSE
         A(1) = TWO*DT*( DWORK(1) + A0 )
         A(N) = TWO*DT*( DWORK(1) - A0 )
      END IF
C
      IND1 = MD2 + 1
      IND2 = N
C
      DO 40 I = 1, M - 1, 2
         W1 = DWORK(IND1)
         W2 = DWORK(IND2)
         IF ( LSIG ) W2 = -W2
         W3 = TWO*SIN( PIBYM*DBLE( I ) )
         A(I+1) = DT*( W1 + W2 - ( W1 - W2 )/W3 )
         IND1 = IND1 + 1
         IND2 = IND2 - 1
   40 CONTINUE
C
      IND1 = 2
      IND2 = MD2 - 1
C
      DO 50 I = 2, M - 2, 2
         W1 = DWORK(IND1)
         W2 = DWORK(IND2)
         IF ( LSIG ) W2 = -W2
         W3 = TWO*SIN( PIBYM*DBLE( I ) )
         A(I+1) = DT*( W1 + W2 - ( W1 - W2 )/W3 )
         IND1 = IND1 + 1
         IND2 = IND2 - 1
   50 CONTINUE
C
      RETURN
C *** Last line of DF01MD ***
      END


! { dg-do run }
! { dg-additional-options "-fno-range-check" }
!
! Check compile-time simplification of functions FRACTION, EXPONENT,
! SPACING, RRSPACING and SET_EXPONENT for special values.

program test
  implicit none
  real, parameter :: inf = 2 * huge(0.)
  real, parameter :: nan = 0. / 0.

  call check_positive_zero(fraction(0.))
  call check_negative_zero(fraction(-0.))
  if (.not. isnan(fraction(inf))) STOP 1
  if (.not. isnan(fraction(-inf))) STOP 2
  if (.not. isnan(fraction(nan))) STOP 3

  if (exponent(0.) /= 0) STOP 4
  if (exponent(-0.) /= 0) STOP 5
  if (exponent(inf) /= huge(0)) STOP 6
  if (exponent(-inf) /= huge(0)) STOP 7
  if (exponent(nan) /= huge(0)) STOP 8

  if (spacing(0.) /= spacing(tiny(0.))) STOP 9
  if (spacing(-0.) /= spacing(tiny(0.))) STOP 10
  if (.not. isnan(spacing(inf))) STOP 11
  if (.not. isnan(spacing(-inf))) STOP 12
  if (.not. isnan(spacing(nan))) STOP 13

  call check_positive_zero(rrspacing(0.))
  call check_positive_zero(rrspacing(-0.))
  if (.not. isnan(rrspacing(inf))) STOP 14
  if (.not. isnan(rrspacing(-inf))) STOP 15
  if (.not. isnan(rrspacing(nan))) STOP 16

  call check_positive_zero(set_exponent(0.,42))
  call check_negative_zero(set_exponent(-0.,42))
  if (.not. isnan(set_exponent(inf, 42))) STOP 17
  if (.not. isnan(set_exponent(-inf, 42))) STOP 18
  if (.not. isnan(set_exponent(nan, 42))) STOP 19

contains

  subroutine check_positive_zero(x)
    use ieee_arithmetic
    implicit none
    real, value :: x

    if (ieee_class (x) /= ieee_positive_zero) STOP 20
  end

  subroutine check_negative_zero(x)
    use ieee_arithmetic
    implicit none
    real, value :: x

    if (ieee_class (x) /= ieee_negative_zero) STOP 21
  end

end


program scalars
use M_anything,only : anyscalar_to_real
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
use,intrinsic :: iso_fortran_env, only : real32, real64, real128
implicit none
integer               :: ios

integer(kind=int8)    :: tiny=   huge(0_int8)
integer(kind=int16)   :: small=  huge(0_int16     )
integer(kind=int32)   :: medium= huge(0_int32)
integer(kind=int64)   :: large=  huge(0_int64)
real(kind=real32)     :: rs= huge(0.0_real32)
real(kind=real64)     :: rm= huge(0.0_real64)
real(kind=real128)    :: rl= huge(0.0_real128)

101 format(a10,"|",i39,"|",i11,"|",i39)
102 format(a10,"|",g0,t55,"|",i11,"|",g0)
   write(*,*)'First show the intrinsic variables of various KINDS we will be using'
   write(*,*) '  NAME   |VALUE                                  |KIND(VALUE)|10**RANGE(VALUE)'
   write(*,102) 'rs     ',rs,     kind(rs),     10.0_real32**range(rs)
   write(*,102) 'rm     ',rm,     kind(rm),     10.0_real64**range(rm)
   write(*,102) 'rl     ',rl,     kind(rl),     10.0_real128**range(rl)
   write(*,102) 'tiny   ',tiny,   kind(tiny)
   write(*,102) 'small  ',small,  kind(small)
   write(*,102) 'medium ',medium, kind(medium)
   write(*,102) 'large  ',large,  kind(large)

   write(*,*)'Test squarei with all INTEGER KINDs:'
   write(*,*)'(and given the following facts what is the expected output?)'
   write(*,*)'FACTS:'
   write(*,*)'127 * 127 = 16129'
   write(*,*)'32767 * 32767 = 1073676289'
   write(*,*)'2147483647 * 2147483647 = 4611686014132420609'
   write(*,*)'9223372036854775807 * 9223372036854775807 = 85070591730234615847396907784232501249'
   write(*,*)'170141183460469231731687303715884105727 * 170141183460469231731687303715884105727 =&
   &28948022309329048855892746252171976962977213799489202546401021394546514198529'
   write(*,*)'OUTPUT:'
202 format(a,*(g0:,'; '))
   write(*,202,iostat=ios) 'SQUAREI()  :',squarei(tiny),  squarei(small), squarei(medium), squarei(large)
   write(*,202,iostat=ios) 'SQUAREI()  :',                squarei(rs),    squarei(rm),     squarei(rl)

contains

!! THIS FUNCTION CAN TAKE AN INTEGER OR REAL OF ANY TYPE KNOWN TO ANYSCALAR_TO_REAL() AS AN ARGUMENT
function squarei(invalue) result (dvalue)  ! square an integer value generically
use M_anything, only : anyscalar_to_real
implicit none
class(*),intent(in)  :: invalue
real                 :: invalue_local
real                 :: dvalue
real,parameter       :: biggest=sqrt(real(0.0,kind=real128))
   invalue_local=anyscalar_to_real(invalue)
   !if(invalue_local.gt.biggest)then
   !   write(*,*)'ERROR:*squarei* input value to big=',invalue_local
   !endif
   dvalue=invalue_local*invalue_local
end function squarei

end program scalars


program Matrix_Transpose
implicit none
    integer,parameter :: rows1 = 2 , columns1 = 3
    integer,parameter :: rows2 = 3 , columns2 = 2
    integer :: matrix1(rows1,columns1),matrix2(rows2,columns2)
    integer :: r,c

    read*,((matrix1(r,c),c=1,columns1),r=1,rows1)

    do r=1 , rows1
        do c=1 , columns1
            matrix2(c,r) = matrix1(r,c)
        end do
    end do

    write(*,"(3(2I4,/))")((matrix2(c,r),r=1,columns2),c=1,rows2)

end program


module mod_sort
  implicit none
  private
  public :: swap, quick_sort, merge_sort, heap_sort, comb_sort
  public :: shell_sort, insertion_sort, gnome_sort, shaker_sort
  public :: bitonic_sort
contains
  subroutine swap(a,b)
    implicit none
    integer, intent(inout) :: a, b
    integer :: c
    c = a
    a = b
    b = c
    return
  end subroutine swap
  recursive subroutine quick_sort(a)
    implicit none
    integer, intent(inout) :: a(:)
    integer :: n, l, r, p
    n = size(a)
    l = 1
    r = n
    p = a((l+r)/2)+a(l)+a(r)-max(a((l+r)/2),a(l),a(r))-min(a((l+r)/2),a(l),a(r))
    do
      do while (a(l).lt.p)
        l = l+1
      end do
      do while (a(r).gt.p)
        r = r-1
      end do
      if (l.ge.r) exit
      call swap(a(l),a(r))
      l = l+1
      r = r-1
    end do
    if (l.gt.2) call quick_sort(a(1:l-1))
    if (n.gt.r+1) call quick_sort(a(r+1:n))
    return
  end subroutine quick_sort
  subroutine merge_sort(a)
    implicit none
    integer, intent(inout) :: a(:)
    integer :: n, m, l, i, u
    n = size(a)
    m = n
    l = 1
    do while (m.gt.1)
      do i = 1, m/2
        u = min(2*i*l,n)
        call merger(a(2*(i-1)*l+1:(2*i-1)*l),a((2*i-1)*l+1:u))
      end do
      l = 2*l
      m = (m+1)/2
    end do
    return
  end subroutine merge_sort
  subroutine merger(a1,a2)
    implicit none
    integer, intent(inout) :: a1(:), a2(:)
    integer :: a(size(a1)+size(a2))
    integer :: i1, i2, n1, n2
    i1 = 1
    i2 = 1
    n1 = size(a1)
    n2 = size(a2)
    do while (i1.le.n1.and.i2.le.n2)
      if (a1(i1).le.a2(i2)) then
        a(i1+i2-1) = a1(i1)
        i1 = i1+1
      else
        a(i1+i2-1) = a2(i2)
        i2 = i2+1
       end if
    end do
    if (i1.le.n1) then
      a(i1+i2-1:n1+n2) = a1(i1:n1)
    else if (i2.le.n2) then
      a(i1+i2-1:n1+n2) = a2(i2:n2)
    end if
    a1 = a(1:n1)
    a2 = a(n1+1:n1+n2)
    return
  end subroutine merger
  subroutine heap_sort(a)
    implicit none
    integer, intent(inout) :: a(:)
    integer :: n, i, j, k
    n = size(a)
    do i = 1, n
      j = i
      do while (j.gt.1)
        k = j/2
        if (a(j).gt.a(k)) call swap(a(j),a(k))
        j = k
      end do
    end do
    do i = n, 1, -1
      call swap(a(i),a(1))
      j = 1
      do while (2*j.lt.i)
        k = 2*j
        if ((k.lt.i-1).and.(a(k+1).gt.a(k))) k = k+1
        if (a(j).lt.a(k)) call swap(a(j),a(k))
        j = k
      end do
    end do
    return
  end subroutine heap_sort
  subroutine comb_sort(a)
    implicit none
    integer, intent(inout) :: a(:)
    logical :: ok
    integer :: n, i, h
    n = size(a)
    h = n
    ok = .false.
    do while ((h.gt.1).or.(.not.ok))
      if (h.gt.1) then
        h = (10*h)/13
        if ((h.eq.9).or.(h.eq.10)) h = 11
      end if
      ok = .true.
      do i = 1, n-h
        if (a(i).gt.a(i+h)) then
          call swap(a(i),a(i+h))
          ok = .false.
        end if
      end do
    end do
    return
  end subroutine comb_sort
  subroutine shell_sort(a)
    implicit none
    integer, intent(inout) :: a(:)
    integer :: n, i, h
    n = size(a)
    h = 1
    do while (3*h+1.lt.n)
      h = 3*h+1
    end do
    do while (h.ge.1)
      do i = 1, h
        call insertion_sort(a(i:n:h))
      end do
      h = (h-1)/3
    end do
    return
  end subroutine shell_sort
  subroutine insertion_sort(a)
    implicit none
    integer, intent(inout) :: a(:)
    integer :: n, i, j, t
    n = size(a)
    do i = 2, n
      if (a(i).ge.a(i-1)) cycle
      t = a(i)
      j = i
      do while ((j.gt.1).and.(t.lt.a(j-1)))
        a(j) = a(j-1)
        j = j-1
      end do
      a(j) = t
    end do
    return
  end subroutine insertion_sort
  subroutine gnome_sort(a)
    implicit none
    integer, intent(inout) :: a(:)
    integer :: n, i
    n = size(a)
    i = 2
    do while (i.le.n)
      if (a(i).ge.a(i-1)) then
        i = i+1
        cycle
      end if
      call swap(a(i),a(i-1))
      i = i-1
      if (i.eq.1) i = 2
    end do
    return
  end subroutine gnome_sort
  subroutine shaker_sort(a)
    implicit none
    integer, intent(inout) :: a(:)
    integer :: n, l, r, m, i
    n = size(a)
    l = 1
    r = n
    do
      m = l
      do i = l, r-1
        if (a(i).gt.a(i+1)) then
          call swap(a(i),a(i+1))
          m = i
        end if
      end do
      r = m
      if (l.eq.r) exit
      m = r
      do i = r, l+1, -1
        if (a(i).lt.a(i-1)) then
          call swap(a(i),a(i-1))
          m = i
        end if
      end do
      l = m
      if (l.eq.r) exit
    end do
    return
  end subroutine shaker_sort
  subroutine bitonic_sort(a)
    implicit none
    integer, intent(inout) :: a(:)
    integer :: n, i
    n = size(a)
    if (n.eq.1) return
    call bitonic_sorter(a(1:n/2),.false.)
    call bitonic_sorter(a(n/2+1:n),.true.)
    call bitonic_merger(a,.true.)
    return
  end subroutine bitonic_sort
  recursive subroutine bitonic_sorter(a,ascend)
    implicit none
    integer, intent(inout) :: a(:)
    logical, intent(in) :: ascend
    integer :: n, i
    n = size(a)
    if (n.eq.1) return
    call bitonic_sorter(a(1:n/2),.not.ascend)
    call bitonic_sorter(a(n/2+1:n),ascend)
    call bitonic_merger(a,ascend)
    return
  end subroutine bitonic_sorter
  recursive subroutine bitonic_merger(a,ascend)
    implicit none
    integer, intent(inout) :: a(:)
    logical, intent(in) :: ascend
    integer :: n, m, i
    n = size(a)
    if (n.eq.1) return
    m = max_pow_of_2(n)
    do i = 1, n-m
      if ((a(i).gt.a(i+m)).eqv.ascend) call swap(a(i),a(i+m))
    end do
    call bitonic_merger(a(1:m),ascend)
    call bitonic_merger(a(m+1:n),ascend)
    return
  end subroutine bitonic_merger
  function max_pow_of_2(n) result(p)
    implicit none
    integer, intent(in) :: n
    integer :: p
    p = 1
    do while (2*p.lt.n)
      p = 2*p
    end do
    return
  end function max_pow_of_2
end module mod_sort


	!------------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This program solves nonlinear Klein-Gordon equation in 1 dimension
	! u_{tt}-u_{xx}+u=Es*|u|^2u
	! using a second order implicit-explicit time stepping scheme.
	!
	! The boundary conditions are u(x=0)=u(2*Lx*\pi),
	! The initial condition is u=sqrt(2)*sech((x-c*t)/sqrt(1-c^2));
	!
	! .. Parameters ..
	!  Nx                   = number of modes in x - power of 2 for FFT
	!  Nt			= number of timesteps to take
	!  Tmax			= maximum simulation time
	!  plotgap		= number of timesteps between plots
	!  pi = 3.14159265358979323846264338327950288419716939937510d0
	!  Lx			= width of box in x direction
	!  ES			= +1 for focusing and -1 for defocusing
	! .. Scalars ..
	!  i			= loop counter in x direction
	!  n			= loop counter for timesteps direction
	!  allocatestatus	= error indicator during allocation
	!  start		= variable to record start time of program
	!  finish		= variable to record end time of program
	!  count_rate		= variable for clock count rate
	!  dt			= timestep
	!  ierr			= error code
	!  plotnum		= number of plot
	! .. Arrays ..
	!  unew 		= approximate solution
	!  u 			= approximate solution
	!  uold 		= approximate solution
	!  nonlin 		= nonlinear term, u^3
	! .. Vectors ..
	!  x			= x locations
	!  time			= times at which save data
	!  en			= total energy
	!  enstr		= strain energy
	!  enpot		= potential energy
	!  enkin		= kinetic energy
	!  name_config		= array to store filename for data to be saved
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!	getgrid.f90	-- Get initial grid of points
	! 	initialdata.f90 -- Get initial data
	!	enercalc.f90 -- Subroutine to calculate the energy
	!	savedata.f90 -- Save initial data
	!	storeold.f90 -- Store old data
	! External libraries required
	! 	OpenMP library

	PROGRAM Kg
	USE omp_lib
	! Declare variables
	IMPLICIT NONE
	INTEGER(kind=4), PARAMETER		:: Nx=1024
	INTEGER(kind=4), PARAMETER		:: Nt=500
	INTEGER(kind=4), PARAMETER		:: plotgap=100
        INTEGER(kind=4), PARAMETER		:: maxiter=50
	REAL(kind=8), PARAMETER			:: &
		pi=3.14159265358979323846264338327950288419716939937510d0
	REAL(kind=8), PARAMETER			::  Lx=9.0d0
	REAL(kind=8), PARAMETER			::  Es=1.0d0
        REAL(kind=8), PARAMETER         	::  c=0.5
        REAL(kind=8), PARAMETER 		::  tol=0.1**12
	REAL(kind=8)				::  dt=5.0d0/REAL(Nt,kind(0d0))
	REAL(kind=8), DIMENSION(1:Nx)	        ::  r,rhs,Mp,p
	REAL(kind=8), DIMENSION(1:Nx)	        ::  x
	REAL(kind=8), DIMENSION(1:Nx)           ::  u
	REAL(kind=8), DIMENSION(1:Nx)           ::  uold
	REAL(kind=8), DIMENSION(1:Nx)           ::  unew
	REAL(kind=8), DIMENSION(1:Nx)           ::  savearray
	REAL(kind=8), DIMENSION(1:Nt+1)         ::  time,enkin,enstr,enpot,en
        REAL(kind=8)                            ::  rsum,rr,rrold,alpha,beta,dx
	INTEGER(kind=4)				::  ierr,i,j,n,allocatestatus,numthreads
	INTEGER(kind=4)				::  start, finish, count_rate, plotnum
        INTEGER(kind=4)                         ::  ip,ipp,im,imm,iter
	CHARACTER*100				::  name_config
	! Start short parallel region to count threads
	numthreads=omp_get_max_threads()
	PRINT *,'There are ',numthreads,' threads.'

	! setup grid
	CALL getgrid(Nx,Lx,pi,name_config,x)
        dx=abs(x(2)-x(1))
	PRINT *,'Setup grid'
	CALL initialdata(Nx,dt,c,x,u,uold)
	plotnum=1
	name_config = 'data/u'
	savearray=REAL(u)
	CALL savedata(Nx,plotnum,name_config,savearray)

        PRINT *,'Transformed initial data'
	CALL enercalc(Nx,dt,Es,&
			enkin(plotnum),enstr(plotnum),&
			enpot(plotnum),en(plotnum),&
			dx,u,uold)

	PRINT *,'Got initial data, starting timestepping'
	time(plotnum)=0.0d0
  	CALL system_clock(start,count_rate)
	DO n=1,Nt
                rr=0.0d0
                rsum=0.0d0
		!$OMP PARALLEL DO PRIVATE(i,ipp,ip,im,imm) reduction(+:rr,rsum) SCHEDULE(static)
		DO i=1,Nx
                        ipp=1+mod(i+2+Nx-1,Nx)
                        ip =1+mod(i+1+Nx-1,Nx)
                        im =1+mod(i-1+Nx-1,Nx)
                        imm=1+mod(i-2+Nx-1,Nx)
			rhs(i)=Es*(u(i)**3) &
                              +(2.0d0*u(i)-uold(i))/(dt*dt) &
                              +0.25d0*(-(1.0d0/12.0d0)*(2.0d0*u(imm)+uold(imm)) &
                                        +(4.0d0/3.0d0)*(2.0d0*u(im)+uold(im)) &
                                        -(5.0d0/2.0d0)*(2.0d0*u(i)+uold(i)) &
                                        +(4.0d0/3.0d0)*(2.0d0*u(ip)+uold(ip)) &
                                       -(1.0d0/12.0d0)*(2.0d0*u(ipp)+uold(ipp)))/(dx*dx) &
                              -0.25d0*(2.0d0*u(i)+uold(i))
                        r(i)=rhs(i)-u(i)*(1.0d0/(dt*dt) + 0.25d0) &
                             +0.25d0*(-(1.0d0/12.0d0)*u(imm) &
                                       +(4.0d0/3.0d0)*u(im) &
                                       -(5.0d0/2.0d0)*u(i) &
                                       +(4.0d0/3.0d0)*u(ip) &
                                      -(1.0d0/12.0d0)*u(ipp) )/(dx*dx)
                        p(i)=r(i)
                        unew(i)=u(i)
                        rsum=rsum+abs(r(i))
                        rr=rr+r(i)*r(i)
		END DO
		!$OMP END PARALLEL DO
                iter=0
                DO WHILE (( iter .lt. maxiter ) .and. ( rsum .gt. tol))
		  !$OMP PARALLEL DO PRIVATE(i,im,imm,ip,ipp) SCHEDULE(static)
		  DO i=1,Nx
                        ipp=1+mod(i+2+Nx-1,Nx)
                        ip=1+mod(i+1+Nx-1,Nx)
                        im=1+mod(i-1+Nx-1,Nx)
                        imm=1+mod(i-2+Nx-1,Nx)
			Mp(i)=p(i)*(1.0d0/(dt*dt) + 0.25d0) &
                             -0.25d0*(-(1.0d0/12.0d0)*p(imm) &
                                       +(4.0d0/3.0d0)*p(im) &
                                       -(5.0d0/2.0d0)*p(i) &
                                       +(4.0d0/3.0d0)*p(ip) &
                                      -(1.0d0/12.0d0)*p(ipp) )/(dx*dx)
		  END DO
		  !$OMP END PARALLEL DO
                  alpha=0.0d0
                  !$OMP PARALLEL DO PRIVATE(i) REDUCTION(+:alpha) SCHEDULE(static)
                  DO i=1,Nx
                    alpha=alpha+Mp(i)*p(i)
                  END DO
                  !$OMP END PARALLEL DO
                  alpha=rr/alpha

                  !$OMP PARALLEL DO PRIVATE(i) SCHEDULE(static)
                  DO i=1,Nx
                    unew(i)=unew(i)+alpha*p(i)
                    r(i)=r(i)-alpha*Mp(i)
                  END DO
                  !$OMP END PARALLEL DO

                  rrold=rr
                  rr=0.0d0
                  !$OMP PARALLEL DO PRIVATE(i,im,imm,ip,ipp) REDUCTION(+:rr) SCHEDULE(static)
                  DO i=1,Nx
                    rr=rr+r(i)*r(i)
                  END DO
                  !$OMP END PARALLEL DO
                  beta=rr/rrold
                  rsum=0.0d0
                  !$OMP PARALLEL DO PRIVATE(i,im,imm,ip,ipp) REDUCTION(+:rsum) SCHEDULE(static)
                  DO i=1,Nx
                    p(i)=r(i)+beta*p(i)
                    rsum=rsum+abs(r(i))
                  END DO
                  !$OMP END PARALLEL DO
                  iter=iter+1
                END DO
                ! .. Update old values ..
                CALL storeold(Nx,unew,u,uold)
		IF (mod(n,plotgap)==0) then
			plotnum=plotnum+1
			time(plotnum)=n*dt
			PRINT *,'time',n*dt,' iterations ',iter
			CALL enercalc(Nx,dt,Es,&
				enkin(plotnum),enstr(plotnum),&
				enpot(plotnum),en(plotnum),dx,&
				u,uold)
			CALL savedata(Nx,plotnum,name_config,unew)
		END IF
	END DO
	PRINT *,'Finished time stepping'
	CALL system_clock(finish,count_rate)
	PRINT*,'Program took ',&
		REAL(finish-start,kind(0d0))/REAL(count_rate,kind(0d0)),&
		'for Time stepping'
	CALL saveresults(Nt,plotgap,time(1:1+n/plotgap),en(1:1+n/plotgap),&
			enstr(1:1+n/plotgap),enkin(1:1+n/plotgap),&
                        enpot(1:1+n/plotgap))

	! Save times at which output was made in text format
	PRINT *,'Saved data'
        CALL errorcalc(Nt,Nx,dt,c,x,u)

	PRINT *,'Program execution complete'
	END PROGRAM Kg


! la.f90
! author: sunder

!-----------------------------------------------------------------------
! Find inverse of a matrix
!-----------------------------------------------------------------------

subroutine MatrixInverse(N,A,iA)
  implicit none
  integer          :: N
  double precision :: A(N,N), iA(N,N)
  !
  integer          :: i,j,ml(1)
  double precision :: piv
  double precision :: temp(2*N)
  double precision :: C(2*N,N)
  !
  C(1:N,:)     = TRANSPOSE(A)
  C(N+1:2*N,:) = 0.
  do i = 1, N
     C(N+i,i) = 1.0d0
  end do
  !
  ! Forward elimination and row swapping (if necessary)
  !
  do i = 1, N
     ! If pivot element is zero, then swap rows
     ml = MAXLOC(ABS(C(i,i:N)))
     j = i - 1 + ml(1)
     temp   = C(:,j)
     C(:,j) = C(:,i)
     C(:,i) = temp
     if (C(i,i) .eq. 0.0d0) THEN
        print *, 'ERROR. Matrix is singular!'
        do j = 1, N
           print *, A(j,:)
        end do
        stop
     end if
     piv    = 1.0d0/C(i,i)
     C(:,i) = C(:,i)*piv
    do j = i+1, N
        C(:,j) = C(:,j) - C(i,j)*C(:,i)
     end do
  end do
  !
  ! Back substitution
  !
  do i = N,1,-1
    do j = i-1,1,-1
        C(:,j) = C(:,j) - C(i,j)*C(:,i)
     end do
  end do
  !
  iA = transpose( C(N+1:2*N,:) )
  !
end subroutine MatrixInverse


program limits_test
    use, intrinsic :: iso_fortran_env, only : INT8, INT16, INT32, INT64, &
                                              REAL32, REAL64, REAL128
    implicit none
    integer(kind=INT8) :: i8
    integer(kind=INT16) :: i16
    integer(kind=INT32) :: i32
    integer(kind=INT64) :: i64
    real(kind=REAL32) :: x32
    real(kind=REAL64) :: x64
    real(kind=REAL128) :: x128

    print '(A)', 'integer:'

    print '(A)', 'huge'
    print *, huge(i8)
    print *, huge(i16)
    print *, huge(i32)
    print *, huge(i64)

    print '(A)', 'digits'
    print *, digits(i8)
    print *, digits(i16)
    print *, digits(i32)
    print *, digits(i64)

    print '(A)', 'range'
    print *, range(i8)
    print *, range(i16)
    print *, range(i32)
    print *, range(i64)

    print '(A)', 'real:'

    print '(A)', 'huge:'
    print *, 32, huge(x32)
    print *, 64, huge(x64)
    print *, 128, huge(x128)

    print '(A)', 'tiny:'
    print *, 32, tiny(x32)
    print *, 64, tiny(x64)
    print *, 128, tiny(x128)

    print '(A)', 'epsilon:'
    print *, 32, epsilon(x32)
    print *, 64, epsilon(x64)
    print *, 128, epsilon(x128)

    print '(A)', 'range:'
    print *, 32, range(x32)
    print *, 64, range(x64)
    print *, 128, range(x128)

    print '(A)', 'minexponent:'
    print *, 32, minexponent(x32)
    print *, 64, minexponent(x64)
    print *, 128, minexponent(x128)

    print '(A)', 'maxexponent:'
    print *, 32, maxexponent(x32)
    print *, 64, maxexponent(x64)
    print *, 128, maxexponent(x128)

    print '(A)', 'precision:'
    print *, 32, precision(x32)
    print *, 64, precision(x64)
    print *, 128, precision(x128)

    print '(A)', 'digits:'
    print *, 32, digits(x32)
    print *, 64, digits(x64)
    print *, 128, digits(x128)

end program limits_test


      subroutine sphere_setprob(revs_per_second)
      implicit none

      double precision revs_per_second, rps

      double precision pi
      common /compi/ pi

      common /spherecomm/ rps

      pi = 4.d0*atan(1.d0)

      rps = revs_per_second

      end


module bac
  implicit none

contains

  subroutine Gennum(n)
    integer, intent(out) :: n(4)
    integer :: i, j
    real :: r

    call random_number(r)
    n(1) = int(r * 9.0) + 1
    i = 2

outer: do while (i <= 4)
         call random_number(r)
         n(i) = int(r * 9.0) + 1
inner:   do j = i-1 , 1, -1
           if (n(j) == n(i)) cycle outer
         end do inner
         i = i + 1
       end do outer

  end subroutine Gennum

  subroutine Score(n, guess, b, c)
    character(*), intent(in) :: guess
    integer, intent(in) :: n(0:3)
    integer, intent(out) :: b, c
    integer :: digit, i, j, ind

    b = 0; c = 0
    do i = 1, 4
      read(guess(i:i), "(i1)") digit
      if (digit == n(i-1)) then
        b = b + 1
      else
        do j = i, i+2
          ind = mod(j, 4)
          if (digit == n(ind)) then
            c = c + 1
            exit
          end if
        end do
      end if
    end do

 end subroutine Score

end module bac

program Bulls_and_Cows
   use bac
   implicit none

   integer :: n(4)
   integer :: bulls=0, cows=0, tries=0
   character(4) :: guess

   call random_seed
   call Gennum(n)

   write(*,*) "I have selected a number made up of 4 digits (1-9) without repetitions."
   write(*,*) "You attempt to guess this number."
   write(*,*) "Every digit in your guess that is in the correct position scores 1 Bull"
   write(*,*) "Every digit in your guess that is in an incorrect position scores 1 Cow"
   write(*,*)

   do while (bulls /= 4)
     write(*,*) "Enter a 4 digit number"
     read*, guess
     if (verify(guess, "123456789") /= 0) then
       write(*,*) "That is an invalid entry. Please try again."
       cycle
     end if
     tries = tries + 1
     call Score (n, guess, bulls, cows)
     write(*, "(a, i1, a, i1, a)") "You scored ", bulls, " bulls and ", cows, " cows"
     write(*,*)
   end do

   write(*,"(a,i0,a)") "Congratulations! You correctly guessed the correct number in ", tries, " attempts"

end program Bulls_and_Cows


MODULE ran001
  IMPLICIT NONE
  SAVE

  INTEGER :: n= 9876
END MODULE ran001

SUBROUTINE random0(ran)
  USE ran001
  IMPLICIT NONE

  REAL,INTENT (out) :: ran
  n = MOD (8121 * n + 28411,134456)
  ran = REAL (n) / 134456.
END SUBROUTINE random0

SUBROUTINE seed (iseed)
  USE ran001
IMPLICIT NONE

INTEGER, INTENT (in) :: iseed
  n = ABS (iseed)
END SUBROUTINE

PROGRAM test_random0
  IMPLICIT NONE
  REAL    :: ave
  INTEGER :: i
  INTEGER :: iseed
  INTEGER :: iseq
  REAL    :: ran
  REAL    :: sum

  WRITE (*,*) 'Enter seed: '
  READ (*,*) iseed

  CALL seed(iseed)
  WRITE (*,*) '10 random numbers '
  DO i = 1, 10
    CALL random0(ran)
    WRITE (*,'(3X,F16.6)') ran
  END DO
  WRITE (*,*) 'Average of 5 consecutive 1000-sample sequence'
  DO iseq = 1, 5
    sum = 0.
    DO i = 1, 1000
      CALL random0(ran)
      sum = sum + ran
    END DO
    ave = sum / 1000.
    WRITE (*,'(3X, F16.6)') ave
  END DO
END PROGRAM test_random0


SUBROUTINE sparin(kv,kdiag)
!
! This subroutine performs Cholesky factorisation on a symmetric
! skyline global matrix.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN OUT)::kv(:)
 INTEGER,INTENT(IN)::kdiag(:)
 INTEGER::n,i,ki,l,kj,j,ll,m,k
 REAL(iwp)::x
 n=UBOUND(kdiag,1)
 kv(1)=SQRT(kv(1))
 DO i=2,n
   ki=kdiag(i)-i
   l=kdiag(i-1)-ki+1
   DO j=l,i
     x=kv(ki+j)
     kj=kdiag(j)-j
     IF(j/=1)THEN
       ll=kdiag(j-1)-kj+1
       ll=max(l,ll)
       IF(ll/=j)THEN
         m=j-1
         DO k=ll,m
           x=x-kv(ki+k)*kv(kj+k)
         END DO
       END IF
     END IF
     kv(ki+j)=x/kv(kj+j)
   END DO
   kv(ki+i)=SQRT(x)
 END DO
RETURN
END SUBROUTINE sparin


   subroutine fort_enforce_consistent_e(lo,hi,state, &
                                        state_l1,state_l2,state_l3,state_h1,state_h2,state_h3) &
     bind(C,name="fort_enforce_consistent_e")

     use amrex_fort_module, only : rt => amrex_real
     use meth_params_module, only : NVAR, URHO, UMX, UMY, UMZ, UEDEN, UEINT

     implicit none

     integer          :: lo(3), hi(3)
     integer          :: state_l1,state_l2,state_l3,state_h1,state_h2,state_h3
     real(rt) :: state(state_l1:state_h1,state_l2:state_h2,state_l3:state_h3,NVAR)

     ! Local variables
     integer          :: i,j,k
     real(rt) :: u, v, w, rhoInv

     !
     ! Make sure to enforce (rho E) = (rho e) + 1/2 rho (u^2 +_ v^2 + w^2)
     !
     do k = lo(3), hi(3)
        do j = lo(2), hi(2)
           do i = lo(1), hi(1)

              rhoInv = 1.0d0 / state(i,j,k,URHO)

              u = state(i,j,k,UMX) * rhoInv
              v = state(i,j,k,UMY) * rhoInv
              w = state(i,j,k,UMZ) * rhoInv

              state(i,j,k,UEDEN) = state(i,j,k,UEINT) + &
                     0.5d0 * state(i,j,k,URHO) * (u*u + v*v + w*w)

           end do
        end do
     end do

   end subroutine fort_enforce_consistent_e


   subroutine convol(a, b, c, idima, jdima, idimb)

!-------------------------------------------------------------
! Convolve array A with kernel B to yield output array C.
! Input matrix A is dimensioned idima x jdima
! Input matrix B is dimensioned idimb x idimb (idimb must be an odd number)
! Output matrix C is dimensioned idima x jdima
!-------------------------------------------------------------
    implicit real(a-h,o-z)
    implicit integer(i-n)

    real(4) a(idima,jdima)    ! matrix a
    real(4) b(idimb,idimb)    ! matrix b
    real(4) c(idima,jdima)    ! a convolved with b

    ihb = idimb/2
    c = sum(a)/(idima*jdima)

    do j = 1+ihb, jdima-ihb
    do i = 1+ihb, idima-ihb
        c(i,j) = sum(a(i-ihb:i+ihb, j-ihb:j+ihb)*b)
    enddo
    enddo

    return

end subroutine convol


MODULE constants

  ! Constants used by wrfpost

      REAL,       PARAMETER        :: CM2INCH  =   1.0 / 2.54
      REAL,       PARAMETER        :: CP       =   1005.7
      REAL,       PARAMETER        :: GRAV     =      9.81
      INTEGER,    PARAMETER        :: IMISS    = -99999
      INTEGER,    PARAMETER        :: ISMTH    =      0
      INTEGER,    PARAMETER        :: JSMTH    =      0
      REAL,       PARAMETER        :: LAPSE    =      6.5E-03
      REAL,       PARAMETER        :: LV       =      2.5E+06
      REAL,       PARAMETER        :: M2FEET   =      3.281
      REAL,       PARAMETER        :: MPS2KNTS =      1.944
      REAL,       PARAMETER        :: MPS2MPH  =      2.237
      REAL,       PARAMETER        :: PI       =      3.1415927
      REAL,       PARAMETER        :: P0       =   100000.0
      REAL,       PARAMETER        :: R        =    287.04
      REAL,       PARAMETER        :: RV       =    461.5
      REAL,       PARAMETER        :: T0       =    273.15
      REAL,       PARAMETER        :: XMISS    = -99999.9
      REAL,       PARAMETER        :: CPOG     = CP / GRAV
      REAL,       PARAMETER        :: CPOR     = CP / R
      REAL,       PARAMETER        :: DEG2RAD  = PI / 180.0
      REAL,       PARAMETER        :: E        = R / RV
      REAL,       PARAMETER        :: GOR      = GRAV / R
      REAL,       PARAMETER        :: KAPPA    = R / CP
      REAL,       PARAMETER        :: RAD2DEG  = 180.0 / PI
      REAL,       PARAMETER        :: ROG      = R / GRAV
      REAL,       PARAMETER        :: RVOLV    = RV / LV
      REAL,       PARAMETER        :: rmissing = 1.e9

END MODULE constants


! =====================================================
subroutine rp1_ptwise(num_eqn, num_aux, num_waves, q_l, q_r, aux_l, aux_r,    &
                       wave, s, amdq, apdq)
! =====================================================

!     # Pointwise Riemann solver for the acoustics equations in 1d, with
!     #  variable coefficients (heterogeneous media)

! waves:     2
! equations: 2
! aux fields: 2

! Conserved quantities:
!       1 pressure
!       2 velocity

! Auxiliary variables:
!       1 impedance
!       2 sound_speed

!     # auxl(1,i) should contain the impedance Z in cell i
!     # auxl(2,i) should contain the sound speed c in cell i

!     # On input, q_l contains the state vector on the left
!     #           q_r contains the state vector on the right

!     # On output, wave contains the waves,
!     #            s the speeds,
!     #
!     #            amdq = A^- Delta q,
!     #            apdq = A^+ Delta q,
!     #                   the decomposition of the flux difference
!     #                       f(q_l) - f(q_r)
!     #                   into leftgoing and rightgoing parts respectively.
!     #

    implicit none

    ! Input Arguments
    integer, intent(in) :: num_eqn, num_aux, num_waves
    real(kind=8), intent(in out) :: q_l(num_eqn), q_r(num_eqn)
    real(kind=8), intent(in out) :: aux_l(num_aux), aux_r(num_aux)

    ! Output arguments
    real(kind=8), intent(in out) :: wave(num_eqn, num_waves)
    real(kind=8), intent(in out) :: s(num_waves)
    real(kind=8), intent(in out) :: apdq(num_eqn), amdq(num_eqn)

    ! Locals
    real(kind=8) :: delta(2), a(2), zi, zim

!   # Split the jump in q into waves:

!   # Find a(1) and a(2), the coefficients of the 2 eigenvectors
    delta = q_r - q_l

!   # Impedances
    zi = aux_r(1)
    zim = aux_l(1)

    a(1) = (-delta(1) + zi*delta(2)) / (zim + zi)
    a(2) =  (delta(1) + zim*delta(2)) / (zim + zi)

!   # Compute the waves:

    wave(1,1) = -a(1)*zim
    wave(2,1) = a(1)
    s(1) = -aux_l(2)

    wave(1,2) = a(2)*zi
    wave(2,2) = a(2)
    s(2) = aux_r(2)

!   # Compute the leftgoing and rightgoing fluctuations:
!   # Note s(1,i) < 0 and s(2,i) > 0.

    amdq = s(1)*wave(:,1)
    apdq = s(2)*wave(:,2)

    end subroutine rp1_ptwise


MODULE shr_const_mod
   use shr_kind_mod
   integer(SHR_KIND_IN),parameter,private :: R8 = SHR_KIND_R8
   public
   real(R8),parameter :: SHR_CONST_PI = 3.14159265358979323846_R8
   real(R8),parameter :: SHR_CONST_CDAY = 86400.0_R8
   real(R8),parameter :: SHR_CONST_SDAY = 86164.0_R8
   real(R8),parameter :: SHR_CONST_OMEGA = 2.0_R8*SHR_CONST_PI/SHR_CONST_SDAY
   real(R8),parameter :: SHR_CONST_REARTH = 6.37122e6_R8
   real(R8),parameter :: SHR_CONST_G = 9.80616_R8
   real(R8),parameter :: SHR_CONST_STEBOL = 5.67e-8_R8
   real(R8),parameter :: SHR_CONST_BOLTZ = 1.38065e-23_R8
   real(R8),parameter :: SHR_CONST_AVOGAD = 6.02214e26_R8
   real(R8),parameter :: SHR_CONST_RGAS = SHR_CONST_AVOGAD*SHR_CONST_BOLTZ
   real(R8),parameter :: SHR_CONST_MWDAIR = 28.966_R8
   real(R8),parameter :: SHR_CONST_MWWV = 18.016_R8
   real(R8),parameter :: SHR_CONST_RDAIR = SHR_CONST_RGAS/SHR_CONST_MWDAIR
   real(R8),parameter :: SHR_CONST_RWV = SHR_CONST_RGAS/SHR_CONST_MWWV
   real(R8),parameter :: SHR_CONST_ZVIR = (SHR_CONST_RWV/SHR_CONST_RDAIR)-1.0_R8
   real(R8),parameter :: SHR_CONST_KARMAN = 0.4_R8
   real(R8),parameter :: SHR_CONST_PSTD = 101325.0_R8
   real(R8),parameter :: SHR_CONST_PDB = 0.0112372_R8
   real(R8),parameter :: SHR_CONST_TKTRIP = 273.16_R8
   real(R8),parameter :: SHR_CONST_TKFRZ = 273.15_R8
   real(R8),parameter :: SHR_CONST_TKFRZSW = SHR_CONST_TKFRZ - 1.8_R8
   real(R8),parameter :: SHR_CONST_RHODAIR = &
                         SHR_CONST_PSTD/(SHR_CONST_RDAIR*SHR_CONST_TKFRZ)
   real(R8),parameter :: SHR_CONST_RHOFW = 1.000e3_R8
   real(R8),parameter :: SHR_CONST_RHOSW = 1.026e3_R8
   real(R8),parameter :: SHR_CONST_RHOICE = 0.917e3_R8
   real(R8),parameter :: SHR_CONST_CPDAIR = 1.00464e3_R8
   real(R8),parameter :: SHR_CONST_CPWV = 1.810e3_R8
   real(R8),parameter :: SHR_CONST_CPVIR = (SHR_CONST_CPWV/SHR_CONST_CPDAIR)-1.0_R8
   real(R8),parameter :: SHR_CONST_CPFW = 4.188e3_R8
   real(R8),parameter :: SHR_CONST_CPSW = 3.996e3_R8
   real(R8),parameter :: SHR_CONST_CPICE = 2.11727e3_R8
   real(R8),parameter :: SHR_CONST_LATICE = 3.337e5_R8
   real(R8),parameter :: SHR_CONST_LATVAP = 2.501e6_R8
   real(R8),parameter :: SHR_CONST_LATSUB = &
                         SHR_CONST_LATICE + SHR_CONST_LATVAP
   real(R8),parameter :: SHR_CONST_OCN_REF_SAL = 34.7_R8
   real(R8),parameter :: SHR_CONST_ICE_REF_SAL = 4.0_R8
   real(R8),parameter :: SHR_CONST_SPVAL = 1.0e30_R8
END MODULE shr_const_mod


      double precision function DCOS1 (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>>   1994-10-20 DCOS1 Krogh  Changes to use M77CON
c>>   1993-07-21 DCOS1 WV Snyder JPL Original code
c
c     compute (1 - cos(x)) / x**2.
c
c--D replaces "?": ?COS1
c
      double precision X
      double precision C, SINC
c
      if (x .eq. 0.0d0) then
         dcos1 = 0.5d0
      else
         c = cos(x)
         if (c .le. 0.0) then
            dcos1 = (1.0d0 - c ) / x*x
         else
            sinc = sin(x) / x
            dcos1 = sinc**2 / (1.0d0 + c)
         end if
      end if
      return
      end


!
!     (c) 2019 Guide Star Engineering, LLC
!     This Software was developed for the US Nuclear Regulatory Commission (US NRC)
!     under contract "Multi-Dimensional Physics Implementation into Fuel Analysis under
!     Steady-state and Transients (FAST)", contract # NRC-HQ-60-17-C-0007
!
!    NEMO - Numerical Engine (for) Multiphysics Operators
! Copyright (c) 2007, Stefano Toninel
!                     Gian Marco Bianchi  University of Bologna
!              David P. Schmidt    University of Massachusetts - Amherst
!              Salvatore Filippone University of Rome Tor Vergata
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
!     1. Redistributions of source code must retain the above copyright notice,
!        this list of conditions and the following disclaimer.
!     2. Redistributions in binary form must reproduce the above copyright notice,
!        this list of conditions and the following disclaimer in the documentation
!        and/or other materials provided with the distribution.
!     3. Neither the name of the NEMO project nor the names of its contributors
!        may be used to endorse or promote products derived from this software
!        without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
! ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
! ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
!---------------------------------------------------------------------------------
!
! $Id: geom_tet_dihedral_angle.f90 3093 2008-04-22 14:51:09Z sfilippo $
!
! Description:
!    Calculates the smallest dihedral angle (in radians).
!    Note that dihedral angle is equal to the angle between normal vectors.
!    WARNING! Only tets are currently supported.
!
SUBMODULE(tools_mesh_basics) geom_tet_dihedral_angle_implementation
    USE class_vector, ONLY : vector, OPERATOR(.dot.)
    IMPLICIT NONE

    CONTAINS

        MODULE PROCEDURE geom_tet_dihedral_angle
            USE class_psblas, ONLY : psb_dpk_
            USE tools_math,   ONLY : Pi
            IMPLICIT NONE
            !!
            INTEGER :: if1, if2
            REAL(psb_dpk_) :: arg   !! argument of the acos function
            REAL(psb_dpk_) :: angle !! between two faces
            TYPE(vector)   :: unitnorm(4)

            unitnorm(:) = af(:)%unit()

            largest  = 0.d0 !! Initialize to smallest possible value
            smallest = pi   !! Initialize to largest possible value

            DO if2 = 1, 3
                DO if1 = if2 + 1, 4
                    ! cosine = dot product of two vectors/divided by the product of their magnitude

                    ! area contains the normal scaled so the mag. = the face area
                    arg = (unitnorm(if1) .dot. unitnorm(if2))

                    angle = ACOS(arg)

                    largest  = MAX(largest,angle)
                    smallest = MIN(smallest,angle)
                ENDDO
            ENDDO

        END PROCEDURE geom_tet_dihedral_angle

END SUBMODULE geom_tet_dihedral_angle_implementation