      subroutine dot_product_6_planes(vector, dot)

C #####################################################################
C
C     PURPOSE -
C
C          Take the dot product of the input vector with 6 internaly
C          defined unit vectors and return the 6 results.
C
C          We wish to determine which of 6 quadrents a vector lies in.
C          To do this we first take the dot product of the vector with
C          the unit normal to 6 planes defined by the unit vector defined
C          below.
C                             sqrt2d2, sqrt2d2, 0.0d0,
C                            nsqrt2d2, sqrt2d2, 0.0d0,
C                             sqrt2d2, 0.0d0  , sqrt2d2,
C                            nsqrt2d2, 0.0d0  , sqrt2d2,
C                             0.0d0  , sqrt2d2, sqrt2d2,
C                             0.0d0  ,nsqrt2d2, sqrt2d2
C
C     INPUT ARGUMENTS
C
C         vector -    a 3 component vector
C
C     OUTPUT ARGUMENTS -
C
C         dot   - a 6 component array with the dot product of
C                 vector with 6 planes.
C
C     AUTHOR
C
C         Carl W. Gable  gable@lanl.gov (Los Alamos National Laboratory)
C
C     CHANGE HISTORY -
C
C        $Log: dot_product_6_planes.f,v $
C        Revision 2.00  2007/11/05 19:45:52  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.1   Mon Apr 14 16:43:28 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.0   Wed May 08 12:35:52 1996   gable
CPVCS    Initial revision.
C
C ######################################################################
C
      implicit none
      real*8 dot(6)
      real*8 vector(3)
      real*8 fnormal(3,6)
      integer i, j
C
c
c     Define unit vectors to 6 planes that split a region into 6 sectors
c
      real*8 sqrt2, sqrt2d2, nsqrt2d2
      parameter ( sqrt2   = 0.141421356237310E+01,
     1            sqrt2d2 = 0.707106781186548E+00,
     2           nsqrt2d2 =-0.707106781186548E+00)
c
c     define the unit normal to each plane
*
      data ((fnormal(i,j),i=1,3),j=1,6)  /
     *                             sqrt2d2, sqrt2d2, 0.0d0,
     *                            nsqrt2d2, sqrt2d2, 0.0d0,
     *                             sqrt2d2, 0.0d0  , sqrt2d2,
     *                            nsqrt2d2, 0.0d0  , sqrt2d2,
     *                             0.0d0  , sqrt2d2, sqrt2d2,
     *                             0.0d0  ,nsqrt2d2, sqrt2d2
     *                          /
c
c     Take the dot product of each of the unit normals with the input vector.
c
      dot(1) = fnormal(1,1)*vector(1) +
     *         fnormal(2,1)*vector(2) +
     *         fnormal(3,1)*vector(3)
      dot(2) = fnormal(1,2)*vector(1) +
     *         fnormal(2,2)*vector(2) +
     *         fnormal(3,2)*vector(3)
      dot(3) = fnormal(1,3)*vector(1) +
     *         fnormal(2,3)*vector(2) +
     *         fnormal(3,3)*vector(3)
      dot(4) = fnormal(1,4)*vector(1) +
     *         fnormal(2,4)*vector(2) +
     *         fnormal(3,4)*vector(3)
      dot(5) = fnormal(1,5)*vector(1) +
     *         fnormal(2,5)*vector(2) +
     *         fnormal(3,5)*vector(3)
      dot(6) = fnormal(1,6)*vector(1) +
     *         fnormal(2,6)*vector(2) +
     *         fnormal(3,6)*vector(3)
c
      return
      end


! { dg-do run }
! Tests the fix for PR40646 in which the assignment would cause an ICE.
!
! Contributed by Charlie Sharpsteen  <chuck@sharpsteen.net>
! http://gcc.gnu.org/ml/fortran/2009-07/msg00010.html
! and reported by Tobias Burnus  <burnus@gcc,gnu.org>
!
module bugTestMod
  implicit none
  type:: boundTest
  contains
    procedure, nopass:: test => returnMat
  end type boundTest
contains
  function returnMat( a, b ) result( mat )
    integer:: a, b, i
    double precision, dimension(a,b):: mat
    mat = dble (reshape ([(i, i = 1, a * b)],[a,b]))
    return
  end function returnMat
end module bugTestMod

program bugTest
  use bugTestMod
  implicit none
  integer i
  double precision, dimension(2,2):: testCatch
  type( boundTest ):: testObj
  testCatch = testObj%test(2,2)  ! This would cause an ICE
  if (any (testCatch .ne. dble (reshape ([(i, i = 1, 4)],[2,2])))) call abort
end program bugTest
! { dg-final { cleanup-modules "bugTestMod" } }


      subroutine scurv(x1,x2,x3,x4,x5,x6)
c
c     + + + PURPOSE + + +
c     Computes constants for an S-curve given the (X,Y) coordinates
c     of points represented by: (x3,x1), (x4,x2).
c
c     Implements a modification of EPIC equation 2.254, in the form:
c
c                              tmin
c          y = 100 * -------------------------   ;   tmin < -1.0;
c                     tmin + exp(a + b * tmin)
c
c
c   where:
c          the "100" is the upper limit (asymptote) of the curve,
c          "tmin" is the minimum daily temperature (Celsius), and
c          "a" and "b" are the constants computed by SCURV.
c
c      The "a" & "b" returned by SCURVE (x5 & x6) force the curve through
c      the points: (x3, x1) and (x4, x2); ie, (tmin1, y1) and (tmin2, y2).
c      The "100" is a scaling factor which alters the curvature *between*
c      those points.
c
c     FOR EXAMPLE:
c        For TMIN's of -5 and -15, with associated biomass loss
c        fractions of 0.01 and 0.95 respectively,
c        setting x1=0.01, x2=0.95, x3=5.0, x4=15.0
c        yields: x5=12.55, x6=0.3465 as values for "a" & "b" respectively.
c
c     Note: The values entered for TMIN's are the ABSOLUTE VALUES
c           of the actual TMIN's; ie, they are POSITIVE NUMBERS.
c           (TMIN is constrained to be less than -1 degrees Celsius.)
c           THIS SHOULD BE CHANGED IN "SCURV" AND IN "PTGRP" AND
c           "RANGE".
c
c
c     Called from RANGE, PTGRP, and PRGRA.
c     Author(s): Williams, Arnold, Weltz, Ferris, Meyer
c     Reference in User Guide:
c
c     Changes:
c
c     Version: This module recoded from WEPP version 92.25.
c     Date recoded: 07/02/92.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real x1, x2, x3, x4, x5, x6
c
c     + + + ARGUMENT DEFINITIONS + + +
c     x1     - frost damage fraction for 1st point.
c     x2     - frost damage fraction for 2nd point.
c     x3     - temperature associated with 1st point.
c     x4     - temperature associated with 2nd point.
c     x5     - 1st constant computed by SCURV.
c     x6     - 2nd constant computed by SCURV.
c
c     + + + LOCAL VARIABLES + + +
      real xx, yy
c
c     + + + END SPECIFICATIONS + + +
c
c
      xx = alog(x3/(x1/100.)-x3)
      yy = alog(x4/(x2/100.)-x4)
      x6 = ((xx-yy)/(x4-x3))
      x5 = (xx+x3*x6)
      return
      end


! NAME:   PI SPMD final version without false sharing
! This program will numerically compute the integral of
!                   4/(1+x*x)
! from 0 to 1.  The value of this integral is pi -- which
! is great since it gives us an easy way to check the answer.

! The program was parallelized using OpenMP and an SPMD
! algorithm.  The following OpenMP specific lines were
! added:

! (1) A line to include omp.h -- the include file that
! contains OpenMP's function prototypes and constants.

! (2) A pragma that tells OpenMP to create a team of threads
! with an integer variable i being created for each thread.

! (3) two function calls: one to get the thread ID (ranging
! from 0 to one less than the number of threads), and the other
! returning the total number of threads.

! (4) A "single" construct so only one thread prints the number
! of threads.

! (5) A cyclic distribution of the loop by changing loop control
! expressions to run from the thread ID incremented by the number
! of threads.  Local sums accumlated into sum[id].

! (6) A barrier to make sure everyone's done.

! (7) A single construct so only one thread combines the local
! sums into a single global sum.

! Note that this program avoids the false sharing problem
! by storing partial sums into a private scalar.

! History: C Code written by Tim Mattson, 11/1999
!          Adapted to Fortran code by Helen He and Tim Mattson, 09/2017
!          Changed to Fortran90 code by Helen He, 11/2020

  PROGRAM MAIN
  USE OMP_LIB
  IMPLICIT NONE

  INTEGER :: i, j, id, numthreads, nthreads
  INTEGER, PARAMETER :: num_steps=100000000
  INTEGER, PARAMETER :: MAX_THREADS=4
  REAL*8 :: pi, real_sum, step, full_sum, x
  REAL*8 :: start_time, run_time
  REAL*8 :: sum(0:MAX_THREADS-1)
  REAL*8 :: partial_sum

  full_sum = 0.0

  step = 1.0 / num_steps
  start_time = OMP_GET_WTIME()

  DO j = 1, MAX_THREADS
     CALL OMP_SET_NUM_THREADS(j)
     full_sum = 0.0
     start_time = OMP_GET_WTIME()

!$OMP PARALLEL PRIVATE(i, id, numthreads, partial_sum, x)
     id = OMP_GET_THREAD_NUM()
     numthreads = OMP_GET_NUM_THREADS()
     partial_sum = 0.0

!$OMP SINGLE
     nthreads = numthreads
!$OMP END SINGLE NOWAIT

     DO i = id, num_steps - 1, numthreads
        x = (i + 0.5) * step
        partial_sum = partial_sum + 4.0 / (1.0 + x*x)
     ENDDO

!$OMP CRITICAL
     full_sum = full_sum + partial_sum
!$OMP END CRITICAL

!$OMP END PARALLEL

     pi = step * full_sum
     run_time = OMP_GET_WTIME() - start_time
     WRITE(*,100) pi, run_time, nthreads
100  FORMAT('pi is ',f15.8,' in ',f8.3,'secs and ',i3,' threads')
  ENDDO

  END PROGRAM MAIN


program piqpr16

!   This program implements the BBP algorithm to generate a few hexadecimal
!   digits beginning immediately after a given position id, or in other words
!   beginning at position id + 1.  The maximum value of id is not known for
!   this code, but it is believed to be at least 10^14, depending on system.
!   Results for a given position id can be checked by repeating with id-1 or
!   id+1, and verifying that the hex digits perfectly overlap with an offset of
!   one, except possibly for a few trailing digits.  The resulting fractions
!   are typically accurate to at least 25 decimal digits, and to at least 20
!   hex digits.  This code runs reasonably fast on IBM systems and others that
!   treat "real*16" as double-double, but typically rather slowly on systems
!   that treat "real*16" as software-based IEEE 128-bit floating-point.

!   David H. Bailey     2006-09-06

implicit none
integer id, nbt
real tm0, tm1
real*16 c1, pid, s1, s2, s3, s4, series
parameter (nbt = 96)
integer ibt(nbt)
character*1 chx(nbt/4)

!  Set the position id here.  Output hex digits beginning after position id,
!  i.e., beginning with position id + 1.

parameter (id = 1000000)

write (6, 1) id
1 format ('Pi hex digit computation'/'position =',i12)

!   Evaluate the four series used in the formula.

call cpu_time (tm0)
s1 = series (1, id)
call ibits (s1, nbt, ibt, chx)
write (6, 2) 1, s1, chx, ibt
2 format ('Sum of series',i2,' ='/f34.30/24a1/96i1.1)
s2 = series (4, id)
call ibits (s2, nbt, ibt, chx)
write (6, 2) 2, s2, chx, ibt
s3 = series (5, id)
call ibits (s3, nbt, ibt, chx)
write (6, 2) 3, s3, chx, ibt
s4 = series (6, id)
call ibits (s4, nbt, ibt, chx)
write (6, 2) 4, s4, chx, ibt

!   Compute the four series results as specified in the BBP formula.

c1 = 1.d0
pid = mod (4.d0 * s1 - 2.d0 * s2 - s3 - s4, c1)
if (pid .lt. 0.d0) pid = pid + 1.d0
call cpu_time (tm1)

!   Output results.

write (6, 3) tm1 - tm0
3 format ('Run complete.  CPU time =',f12.4)
call ibits (pid, nbt, ibt, chx)
write (6, 4) pid, chx, ibt
4 format ('Pi fraction ='/f34.30/24a1/96i1.1)

stop
end

subroutine ibits (x, nbt, ibt, chx)

!   This returns in ibt the first nbt bits of the fraction of the floating-point
!   argument x, and returns the first nbt/4 hex digits in chx.  The argument nbt
!   must be divisible by 4 and must not exceed the number of mantissa bits in
!   the floating-point format used for x.

implicit none
integer i, ii, nbt, ibt(nbt)
real*16 x, y
character*1 chx(nbt/4), hx(0:15)
data hx/'0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', &
   'C', 'D', 'E', 'F'/

y = abs (x)

do i = 1, nbt
  y = 2.d0 * (y - aint (y))
  ibt(i) = int (y)
enddo

do i = 1, nbt / 4
  ii = 8 * ibt(4*i-3) + 4 * ibt(4*i-2) + 2 * ibt(4*i-1) + ibt(4*i)
  chx(i) = hx(ii)
enddo

return
end

function series (m, id)

!   This routine evaluates the series Sum_{k=1}^d (2^(id-k) mod (8*k+m))/(8*k+m).

implicit none
integer id, k, m
real*16 ak, c1, eps, expm1, p, s, series, t
parameter (eps = 1d-32)

c1 = 1.d0
s = 0.d0

!  Sum the series until k exceeds id

do k = 0, id
  ak = 8 * k + m
  p = id - k
  if (p == 0.d0) then
    t = 1.d0
  elseif (ak == 1.d0) then
    t = 0.d0
  else
    t = expm1 (p, ak)
  endif
  s = mod (s + t / ak, c1)
!  write (6, '(i5,3f15.1,f20.15)') k, p, ak, t, s
enddo

!   Complete the computation by manually computing a few terms where k > id.

do k = id + 1, id + 100
  ak = 8 * k + m
  t = 16.d0 ** (id - k)
  if (t .lt. eps) goto 120
  s = mod (s + t / ak, c1)
enddo

120 continue

! write (6, *) 'final s =', s

series = s
return
end

function expm1 (p, ak)

!   expm1 (p, ak) = 16^p mod ak.
!   This routine uses a left-to-right binary exponentiation scheme.

implicit none
integer i, ntp
parameter (ntp = 30)
real*16 ak, expm1, p, p1, pt1, r, tp(ntp)
save tp
data tp/ntp*0.d0/

!   If this is the first call, fill the power of two table tp.

if (tp(1) .eq. 0.d0) then
  tp(1) = 1.d0

  do i = 2, ntp
    tp(i) = 2.d0 * tp(i-1)
  enddo
endif

!   Find the largest power of two less than or equal to p.

do i = 1, ntp
  if (tp(i) .gt. p) goto 100
enddo

100 continue

pt1 = tp(i-1)
p1 = p
r = 1.d0

!  Perform the binary exponentiation scheme.

110 continue

if (p1 .ge. pt1) then
  r = mod (16.d0 * r, ak)
  p1 = p1 - pt1
endif
pt1 = 0.5d0 * pt1
if (pt1 .ge. 1.d0) then
  r = mod (r * r, ak)
  goto 110
endif

expm1 = mod (r, ak)

return
end


   subroutine latin_random ( dim_num, point_num, seed, x )

      !*****************************************************************************80
      !
      !! LATIN_RANDOM returns points in a Latin Random square.
      !
      !  Discussion:
      !
      !    In each spatial dimension, there will be exactly one
      !    point whose coordinate value lies between consecutive
      !    values in the list:
      !
      !      ( 0, 1, 2, ..., point_num ) / point_num
      !
      !  Licensing:
      !
      !    This code is distributed under the GNU LGPL license.
      !
      !  Modified:
      !
      !    08 April 2003
      !
      !  Author:
      !
      !    John Burkardt
      !
      !  Parameters:
      !
      !    Input, integer ( kind = 4 ) DIM_NUM, the spatial dimension.
      !
      !    Input, integer ( kind = 4 ) POINT_NUM, the number of points.
      !
      !    Input/output, integer ( kind = 4 ) SEED, a seed for the random
      !    number generator.
      !
      !    Output, real ( kind = 8 ) X(DIM_NUM,POINT_NUM), the points.
      !
        implicit none

        integer ( kind = 4 ) dim_num
        integer ( kind = 4 ) point_num

        integer ( kind = 4 ) i
        integer ( kind = 4 ) j
        integer ( kind = 4 ) perm(point_num)
        integer ( kind = 4 ) seed
        real ( kind = 8 ) x(dim_num,point_num)
      !
      !  Pick DIM_NUM * POINT_NUM random numbers between 0 and 1.
      !
        call r8mat_uniform_01 ( dim_num, point_num, seed, x )
      !
      !  For spatial dimension I,
      !    pick a random permutation of 1 to POINT_NUM,
      !    force the corresponding I-th components of X to lie in the
      !    interval ( PERM(J)-1, PERM(J) ) / POINT_NUM.
      !
        do i = 1, dim_num

          call perm_uniform ( point_num, seed, perm )

          do j = 1, point_num
            x(i,j) = ( real ( perm(j) - 1, kind = 8 ) + x(i,j) ) &
                     / real ( point_num, kind = 8 )
          end do

        end do

        return
   end
   subroutine get_seed ( seed )

      !*****************************************************************************80
      !
      !! GET_SEED returns a seed for the random number generator.
      !
      !  Discussion:
      !
      !    The seed depends on the current time, and ought to be (slightly)
      !    different every millisecond.  Once the seed is obtained, a random
      !    number generator should be called a few times to further process
      !    the seed.
      !
      !  Licensing:
      !
      !    This code is distributed under the GNU LGPL license.
      !
      !  Modified:
      !
      !    02 August 2004
      !
      !  Author:
      !
      !    John Burkardt
      !
      !  Parameters:
      !
      !    Output, integer ( kind = 4 ) SEED, a pseudorandom seed value.
      !
        implicit none

        integer ( kind = 4 ) seed
        real ( kind = 8 ) temp
        character ( len = 10 ) time
        character ( len = 8 ) today
        integer ( kind = 4 ) values(8)
        character ( len = 5 ) zone

        call date_and_time ( today, time, zone, values )

        temp = 0.0D+00

        temp = temp + real ( values(2) - 1, kind = 8 ) /  11.0D+00
        temp = temp + real ( values(3) - 1, kind = 8 ) /  30.0D+00
        temp = temp + real ( values(5),     kind = 8 ) /  23.0D+00
        temp = temp + real ( values(6),     kind = 8 ) /  59.0D+00
        temp = temp + real ( values(7),     kind = 8 ) /  59.0D+00
        temp = temp + real ( values(8),     kind = 8 ) / 999.0D+00
        temp = temp                                    /   6.0D+00

        do while ( temp <= 0.0D+00 )
          temp = temp + 1.0D+00
        end do

        do while ( 1.0D+00 < temp )
          temp = temp - 1.0D+00
        end do

        seed = int ( real ( huge ( 1 ), kind = 8 ) * temp )
      !
      !  Never use a seed of 0 or maximum integer ( kind = 4 ).
      !
        if ( seed == 0 ) then
          seed = 1
        end if

        if ( seed == huge ( 1 ) ) then
          seed = seed - 1
        end if

        return
   end
   subroutine get_unit ( iunit )

      !*****************************************************************************80
      !
      !! GET_UNIT returns a free FORTRAN unit number.
      !
      !  Discussion:
      !
      !    A "free" FORTRAN unit number is a value between 1 and 99 which
      !    is not currently associated with an I/O device.  A free FORTRAN unit
      !    number is needed in order to open a file with the OPEN command.
      !
      !    If IUNIT = 0, then no free FORTRAN unit could be found, although
      !    all 99 units were checked (except for units 5, 6 and 9, which
      !    are commonly reserved for console I/O).
      !
      !    Otherwise, IUNIT is a value between 1 and 99, representing a
      !    free FORTRAN unit.  Note that GET_UNIT assumes that units 5 and 6
      !    are special, and will never return those values.
      !
      !  Licensing:
      !
      !    This code is distributed under the GNU LGPL license.
      !
      !  Modified:
      !
      !    18 September 2005
      !
      !  Author:
      !
      !    John Burkardt
      !
      !  Parameters:
      !
      !    Output, integer ( kind = 4 ) IUNIT, the free unit number.
      !
        implicit none

        integer ( kind = 4 ) i
        integer ( kind = 4 ) ios
        integer ( kind = 4 ) iunit
        logical lopen

        iunit = 0

        do i = 1, 99

          if ( i /= 5 .and. i /= 6 .and. i /= 9 ) then

            inquire ( unit = i, opened = lopen, iostat = ios )

            if ( ios == 0 ) then
              if ( .not. lopen ) then
                iunit = i
                return
              end if
            end if

          end if

        end do

        return
      end
      function i4_uniform_ab ( a, b, seed )

      !*****************************************************************************80
      !
      !! I4_UNIFORM_AB returns a scaled pseudorandom I4 between A and B.
      !
      !  Discussion:
      !
      !    An I4 is an integer ( kind = 4 ) value.
      !
      !    The pseudorandom number will be scaled to be uniformly distributed
      !    between A and B.
      !
      !  Licensing:
      !
      !    This code is distributed under the GNU LGPL license.
      !
      !  Modified:
      !
      !    02 October 2012
      !
      !  Author:
      !
      !    John Burkardt
      !
      !  Reference:
      !
      !    Paul Bratley, Bennett Fox, Linus Schrage,
      !    A Guide to Simulation,
      !    Second Edition,
      !    Springer, 1987,
      !    ISBN: 0387964673,
      !    LC: QA76.9.C65.B73.
      !
      !    Bennett Fox,
      !    Algorithm 647:
      !    Implementation and Relative Efficiency of Quasirandom
      !    Sequence Generators,
      !    ACM Transactions on Mathematical Software,
      !    Volume 12, Number 4, December 1986, pages 362-376.
      !
      !    Pierre L'Ecuyer,
      !    Random Number Generation,
      !    in Handbook of Simulation,
      !    edited by Jerry Banks,
      !    Wiley, 1998,
      !    ISBN: 0471134031,
      !    LC: T57.62.H37.
      !
      !    Peter Lewis, Allen Goodman, James Miller,
      !    A Pseudo-Random Number Generator for the System/360,
      !    IBM Systems Journal,
      !    Volume 8, Number 2, 1969, pages 136-143.
      !
      !  Parameters:
      !
      !    Input, integer ( kind = 4 ) A, B, the limits of the interval.
      !
      !    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
      !    should NOT be 0.  On output, SEED has been updated.
      !
      !    Output, integer ( kind = 4 ) I4_UNIFORM_AB, a number between A and B.
      !
        implicit none

        integer ( kind = 4 ) a
        integer ( kind = 4 ) b
        integer ( kind = 4 ), parameter :: i4_huge = 2147483647
        integer ( kind = 4 ) i4_uniform_ab
        integer ( kind = 4 ) k
        real ( kind = 4 ) r
        integer ( kind = 4 ) seed
        integer ( kind = 4 ) value

        if ( seed == 0 ) then
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 'I4_UNIFORM_AB - Fatal error!'
          write ( *, '(a)' ) '  Input value of SEED = 0.'
          stop 1
        end if

        k = seed / 127773

        seed = 16807 * ( seed - k * 127773 ) - k * 2836

        if ( seed < 0 ) then
          seed = seed + i4_huge
        end if

        r = real ( seed, kind = 4 ) * 4.656612875E-10
      !
      !  Scale R to lie between A-0.5 and B+0.5.
      !
        r = ( 1.0E+00 - r ) * ( real ( min ( a, b ), kind = 4 ) - 0.5E+00 ) &
          +             r   * ( real ( max ( a, b ), kind = 4 ) + 0.5E+00 )
      !
      !  Use rounding to convert R to an integer between A and B.
      !
        value = nint ( r, kind = 4 )

        value = max ( value, min ( a, b ) )
        value = min ( value, max ( a, b ) )

        i4_uniform_ab = value

        return
   end
   subroutine perm_uniform ( n, seed, p )

      !*****************************************************************************80
      !
      !! PERM_UNIFORM selects a random permutation of N objects.
      !
      !  Licensing:
      !
      !    This code is distributed under the GNU LGPL license.
      !
      !  Modified:
      !
      !    18 November 2008
      !
      !  Author:
      !
      !    John Burkardt
      !
      !  Reference:
      !
      !    Albert Nijenhuis, Herbert Wilf,
      !    Combinatorial Algorithms for Computers and Calculators,
      !    Academic Press, 1978,
      !    ISBN: 0-12-519260-6,
      !    LC: QA164.N54.
      !
      !  Parameters:
      !
      !    Input, integer ( kind = 4 ) N, the number of objects to be permuted.
      !
      !    Input/output, integer ( kind = 4 ) SEED, a seed for the random
      !    number generator.
      !
      !    Output, integer ( kind = 4 ) P(N), the permutation.  P(I) is the "new"
      !    location of the object originally at I.
      !
        implicit none

        integer ( kind = 4 ) n

        integer ( kind = 4 ) i
        integer ( kind = 4 ) i4_uniform_ab
        integer ( kind = 4 ) j
        integer ( kind = 4 ) k
        integer ( kind = 4 ) p(n)
        integer ( kind = 4 ) seed

        do i = 1, n
          p(i) = i
        end do

        do i = 1, n - 1
          j = i4_uniform_ab ( i, n, seed )
          k    = p(i)
          p(i) = p(j)
          p(j) = k
        end do

        return
   end
   subroutine r8mat_transpose_print ( m, n, a, title )

      !*****************************************************************************80
      !
      !! R8MAT_TRANSPOSE_PRINT prints an R8MAT, transposed.
      !
      !  Discussion:
      !
      !    An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
      !
      !  Licensing:
      !
      !    This code is distributed under the GNU LGPL license.
      !
      !  Modified:
      !
      !    14 June 2004
      !
      !  Author:
      !
      !    John Burkardt
      !
      !  Parameters:
      !
      !    Input, integer ( kind = 4 ) M, N, the number of rows and columns.
      !
      !    Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed.
      !
      !    Input, character ( len = * ) TITLE, a title.
      !
        implicit none

        integer ( kind = 4 ) m
        integer ( kind = 4 ) n

        real ( kind = 8 ) a(m,n)
        character ( len = * ) title

        call r8mat_transpose_print_some ( m, n, a, 1, 1, m, n, title )

        return
   end
   subroutine r8mat_transpose_print_some ( m, n, a, ilo, jlo, ihi, jhi, title )

      !*****************************************************************************80
      !
      !! R8MAT_TRANSPOSE_PRINT_SOME prints some of an R8MAT, transposed.
      !
      !  Discussion:
      !
      !    An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
      !
      !  Licensing:
      !
      !    This code is distributed under the GNU LGPL license.
      !
      !  Modified:
      !
      !    10 September 2009
      !
      !  Author:
      !
      !    John Burkardt
      !
      !  Parameters:
      !
      !    Input, integer ( kind = 4 ) M, N, the number of rows and columns.
      !
      !    Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed.
      !
      !    Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print.
      !
      !    Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print.
      !
      !    Input, character ( len = * ) TITLE, a title.
      !
        implicit none

        integer ( kind = 4 ), parameter :: incx = 5
        integer ( kind = 4 ) m
        integer ( kind = 4 ) n

        real ( kind = 8 ) a(m,n)
        character ( len = 14 ) ctemp(incx)
        integer ( kind = 4 ) i
        integer ( kind = 4 ) i2
        integer ( kind = 4 ) i2hi
        integer ( kind = 4 ) i2lo
        integer ( kind = 4 ) ihi
        integer ( kind = 4 ) ilo
        integer ( kind = 4 ) inc
        integer ( kind = 4 ) j
        integer ( kind = 4 ) j2hi
        integer ( kind = 4 ) j2lo
        integer ( kind = 4 ) jhi
        integer ( kind = 4 ) jlo
        character ( len = * ) title

        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) trim ( title )

        if ( m <= 0 .or. n <= 0 ) then
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) '  (None)'
          return
        end if

        do i2lo = max ( ilo, 1 ), min ( ihi, m ), incx

          i2hi = i2lo + incx - 1
          i2hi = min ( i2hi, m )
          i2hi = min ( i2hi, ihi )

          inc = i2hi + 1 - i2lo

          write ( *, '(a)' ) ' '

          do i = i2lo, i2hi
            i2 = i + 1 - i2lo
            write ( ctemp(i2), '(i8,6x)' ) i
          end do

          write ( *, '(''  Row   '',5a14)' ) ctemp(1:inc)
          write ( *, '(a)' ) '  Col'
          write ( *, '(a)' ) ' '

          j2lo = max ( jlo, 1 )
          j2hi = min ( jhi, n )

          do j = j2lo, j2hi

            do i2 = 1, inc
              i = i2lo - 1 + i2
              write ( ctemp(i2), '(g14.6)' ) a(i,j)
            end do

            write ( *, '(i5,a,5a14)' ) j, ':', ( ctemp(i), i = 1, inc )

          end do

        end do

        return
   end
   subroutine r8mat_uniform_01 ( m, n, seed, r )

      !*****************************************************************************80
      !
      !! R8MAT_UNIFORM_01 fills an R8MAT with unit pseudorandom numbers.
      !
      !  Discussion:
      !
      !    An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
      !
      !  Licensing:
      !
      !    This code is distributed under the GNU LGPL license.
      !
      !  Modified:
      !
      !    11 August 2004
      !
      !  Author:
      !
      !    John Burkardt
      !
      !  Reference:
      !
      !    Paul Bratley, Bennett Fox, Linus Schrage,
      !    A Guide to Simulation,
      !    Springer Verlag, pages 201-202, 1983.
      !
      !    Bennett Fox,
      !    Algorithm 647:
      !    Implementation and Relative Efficiency of Quasirandom
      !    Sequence Generators,
      !    ACM Transactions on Mathematical Software,
      !    Volume 12, Number 4, pages 362-376, 1986.
      !
      !    Peter Lewis, Allen Goodman, James Miller,
      !    A Pseudo-Random Number Generator for the System/360,
      !    IBM Systems Journal,
      !    Volume 8, pages 136-143, 1969.
      !
      !  Parameters:
      !
      !    Input, integer ( kind = 4 ) M, N, the number of rows and columns in
      !    the array.
      !
      !    Input/output, integer ( kind = 4 ) SEED, the "seed" value, which
      !    should NOT be 0.  On output, SEED has been updated.
      !
      !    Output, real ( kind = 8 ) R(M,N), the array of pseudorandom values.
      !
        implicit none

        integer ( kind = 4 ) m
        integer ( kind = 4 ) n

        integer ( kind = 4 ) i
        integer ( kind = 4 ), parameter :: i4_huge = 2147483647
        integer ( kind = 4 ) j
        integer ( kind = 4 ) k
        integer ( kind = 4 ) seed
        real ( kind = 8 ) r(m,n)

        do j = 1, n

          do i = 1, m

            k = seed / 127773

            seed = 16807 * ( seed - k * 127773 ) - k * 2836

            if ( seed < 0 ) then
              seed = seed + i4_huge
            end if

            r(i,j) = real ( seed, kind = 8 ) * 4.656612875D-10

          end do
        end do

        return
   end
   subroutine r8mat_write ( output_filename, m, n, table )

      !*****************************************************************************80
      !
      !! R8MAT_WRITE writes an R8MAT file.
      !
      !  Discussion:
      !
      !    An R8MAT is an array of R8 values.
      !
      !  Licensing:
      !
      !    This code is distributed under the GNU LGPL license.
      !
      !  Modified:
      !
      !    31 May 2009
      !
      !  Author:
      !
      !    John Burkardt
      !
      !  Parameters:
      !
      !    Input, character ( len = * ) OUTPUT_FILENAME, the output file name.
      !
      !    Input, integer ( kind = 4 ) M, the spatial dimension.
      !
      !    Input, integer ( kind = 4 ) N, the number of points.
      !
      !    Input, real ( kind = 8 ) TABLE(M,N), the table data.
      !
        implicit none

        integer ( kind = 4 ) m
        integer ( kind = 4 ) n

        integer ( kind = 4 ) j
        character ( len = * ) output_filename
        integer ( kind = 4 ) output_status
        integer ( kind = 4 ) output_unit
        character ( len = 30 ) string
        real ( kind = 8 ) table(m,n)
      !
      !  Open the file.
      !
        call get_unit ( output_unit )

        open ( unit = output_unit, file = output_filename, &
          status = 'replace', iostat = output_status )

        if ( output_status /= 0 ) then
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 'R8MAT_WRITE - Fatal error!'
          write ( *, '(a,i8)' ) '  Could not open the output file "' // &
            trim ( output_filename ) // '" on unit ', output_unit
          output_unit = -1
          stop
        end if
      !
      !  Create a format string.
      !
      !  For less precision in the output file, try:
      !
      !                                            '(', m, 'g', 14, '.', 6, ')'
      !
        if ( 0 < m .and. 0 < n ) then

          write ( string, '(a1,i8,a1,i8,a1,i8,a1)' ) '(', m, 'g', 24, '.', 16, ')'
      !
      !  Write the data.
      !
          do j = 1, n
            write ( output_unit, string ) table(1:m,j)
          end do

        end if
      !
      !  Close the file.
      !
        close ( unit = output_unit )

        return
   end
   subroutine timestamp ( )

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

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

        call date_and_time ( values = values )

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

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

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

        return
   end


      SUBROUTINE CALJY1(ARG,RESULT,JINT)
C---------------------------------------------------------------------
C
C This packet computes first-order Bessel functions of the first and
C   second kind (J1 and Y1), for real arguments X, where 0 < X <= XMAX
C   for Y1, and |X| <= XMAX for J1.  It contains two function-type
C   subprograms,  BESJ1  and  BESY1,  and one subroutine-type
C   subprogram,  CALJY1.  The calling statements for the primary
C   entries are:
C
C           Y = BESJ1(X)
C   and
C           Y = BESY1(X),
C
C   where the entry points correspond to the functions J1(X) and Y1(X),
C   respectively.  The routine  CALJY1  is intended for internal packet
C   use only, all computations within the packet being concentrated in
C   this one routine.  The function subprograms invoke  CALJY1  with
C   the statement
C           CALL CALJY1(ARG,RESULT,JINT),
C   where the parameter usage is as follows:
C
C      Function                  Parameters for CALJY1
C       call              ARG             RESULT          JINT
C
C     BESJ1(ARG)     |ARG| .LE. XMAX       J1(ARG)          0
C     BESY1(ARG)   0 .LT. ARG .LE. XMAX    Y1(ARG)          1
C
C   The main computation uses unpublished minimax rational
C   approximations for X .LE. 8.0, and an approximation from the
C   book  Computer Approximations  by Hart, et. al., Wiley and Sons,
C   New York, 1968, for arguments larger than 8.0   Part of this
C   transportable packet is patterned after the machine-dependent
C   FUNPACK program BESJ1(X), but cannot match that version for
C   efficiency or accuracy.  This version uses rational functions
C   that are theoretically accurate to at least 18 significant decimal
C   digits for X <= 8, and at least 18 decimal places for X > 8.  The
C   accuracy achieved depends on the arithmetic system, the compiler,
C   the intrinsic functions, and proper selection of the machine-
C   dependent constants.
C
C*******************************************************************
C
C The following machine-dependent constants must be declared in
C   DATA statements.  IEEE values are provided as a default.
C
C   XINF   = largest positive machine number
C   XMAX   = largest acceptable argument.  The functions AINT, SIN
C            and COS must perform properly for  ABS(X) .LE. XMAX.
C            We recommend that XMAX be a small integer multiple of
C            sqrt(1/eps), where eps is the smallest positive number
C            such that  1+eps > 1.
C   XSMALL = positive argument such that  1.0-(1/2)(X/2)**2 = 1.0
C            to machine precision for all  ABS(X) .LE. XSMALL.
C            We recommend that  XSMALL < sqrt(eps)/beta, where beta
C            is the floating-point radix (usually 2 or 16).
C
C     Approximate values for some important machines are
C
C                          eps      XMAX     XSMALL      XINF
C
C  CDC 7600      (S.P.)  7.11E-15  1.34E+08  2.98E-08  1.26E+322
C  CRAY-1        (S.P.)  7.11E-15  1.34E+08  2.98E-08  5.45E+2465
C  IBM PC (8087) (S.P.)  5.96E-08  8.19E+03  1.22E-04  3.40E+38
C  IBM PC (8087) (D.P.)  1.11D-16  2.68D+08  3.72D-09  1.79D+308
C  IBM 195       (D.P.)  2.22D-16  6.87D+09  9.09D-13  7.23D+75
C  UNIVAC 1108   (D.P.)  1.73D-18  4.30D+09  2.33D-10  8.98D+307
C  VAX 11/780    (D.P.)  1.39D-17  1.07D+09  9.31D-10  1.70D+38
C
C*******************************************************************
C*******************************************************************
C
C Error Returns
C
C  The program returns the value zero for  X .GT. XMAX, and returns
C    -XINF when BESLY1 is called with a negative or zero argument.
C
C
C Intrinsic functions required are:
C
C     ABS, AINT, COS, LOG, SIN, SQRT
C
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C  Latest modification: March 13, 1992
C
C--------------------------------------------------------------------
      INTEGER I,JINT
      DIMENSION PJ0(7),PJ1(8),PLG(4),PY0(7),PY1(9),P0(6),P1(6),
     1          QJ0(5),QJ1(7),QLG(4),QY0(6),QY1(8),Q0(6),Q1(6)
CS    REAL
      DOUBLE PRECISION
     1   ARG,AX,DOWN,EIGHT,FOUR,HALF,PI2,PJ0,PJ1,PLG,PROD,PY0,
     2   PY1,P0,P1,P17,QJ0,QJ1,QLG,QY0,QY1,Q0,Q1,RESJ,RESULT,
     3   RTPI2,R0,R1,THROV8,TWOPI,TWOPI1,TWOPI2,TWO56,UP,W,WSQ,
     4   XDEN,XINF,XMAX,XNUM,XSMALL,XJ0,XJ1,XJ01,XJ02,XJ11,XJ12,
     5   XY,XY0,XY01,XY02,XY1,XY11,XY12,Z,ZERO,ZSQ
C-------------------------------------------------------------------
C  Mathematical constants
C-------------------------------------------------------------------
CS    DATA EIGHT/8.0E0/,
CS   1     FOUR/4.0E0/,HALF/0.5E0/,THROV8/0.375E0/,
CS   2     PI2/6.3661977236758134308E-1/,P17/1.716E-1/
CS   3     TWOPI/6.2831853071795864769E+0/,ZERO/0.0E0/,
CS   4     TWOPI1/6.28125E0/,TWOPI2/1.9353071795864769253E-03/
CS   5     TWO56/256.0E+0/,RTPI2/7.9788456080286535588E-1/
      DATA EIGHT/8.0D0/,
     1     FOUR/4.0D0/,HALF/0.5D0/,THROV8/0.375D0/,
     2     PI2/6.3661977236758134308D-1/,P17/1.716D-1/
     3     TWOPI/6.2831853071795864769D+0/,ZERO/0.0D0/,
     4     TWOPI1/6.28125D0/,TWOPI2/1.9353071795864769253D-03/
     5     TWO56/256.0D+0/,RTPI2/7.9788456080286535588D-1/
C-------------------------------------------------------------------
C  Machine-dependent constants
C-------------------------------------------------------------------
CS    DATA XMAX/8.19E+03/,XSMALL/1.22E-04/,XINF/3.40E+38/
      DATA XMAX/2.68D+08/,XSMALL/3.72D-09/,XINF/1.79D+308/
C-------------------------------------------------------------------
C  Zeroes of Bessel functions
C-------------------------------------------------------------------
CS    DATA XJ0/3.8317059702075123156E+0/,XJ1/7.0155866698156187535E+0/,
CS   1     XY0/2.1971413260310170351E+0/,XY1/5.4296810407941351328E+0/,
CS   2     XJ01/ 981.0E+0/, XJ02/-3.2527979248768438556E-04/,
CS   3     XJ11/1796.0E+0/, XJ12/-3.8330184381246462950E-05/,
CS   4     XY01/ 562.0E+0/, XY02/ 1.8288260310170351490E-03/,
CS   5     XY11/1390.0E+0/, XY12/-6.4592058648672279948E-06/
      DATA XJ0/3.8317059702075123156D+0/,XJ1/7.0155866698156187535D+0/,
     1     XY0/2.1971413260310170351D+0/,XY1/5.4296810407941351328D+0/,
     2     XJ01/ 981.0D+0/, XJ02/-3.2527979248768438556D-04/,
     3     XJ11/1796.0D+0/, XJ12/-3.8330184381246462950D-05/,
     4     XY01/ 562.0D+0/, XY02/ 1.8288260310170351490D-03/,
     5     XY11/1390.0D+0/, XY12/-6.4592058648672279948D-06/
C-------------------------------------------------------------------
C  Coefficients for rational approximation to ln(x/a)
C--------------------------------------------------------------------
CS    DATA PLG/-2.4562334077563243311E+01,2.3642701335621505212E+02,
CS   1         -5.4989956895857911039E+02,3.5687548468071500413E+02/
CS    DATA QLG/-3.5553900764052419184E+01,1.9400230218539473193E+02,
CS   1         -3.3442903192607538956E+02,1.7843774234035750207E+02/
      DATA PLG/-2.4562334077563243311D+01,2.3642701335621505212D+02,
     1         -5.4989956895857911039D+02,3.5687548468071500413D+02/
      DATA QLG/-3.5553900764052419184D+01,1.9400230218539473193D+02,
     1         -3.3442903192607538956D+02,1.7843774234035750207D+02/
C-------------------------------------------------------------------
C  Coefficients for rational approximation of
C  J1(X) / (X * (X**2 - XJ0**2)),  XSMALL  <  |X|  <=  4.0
C--------------------------------------------------------------------
CS    DATA PJ0/9.8062904098958257677E+05,-1.1548696764841276794E+08,
CS   1       6.6781041261492395835E+09,-1.4258509801366645672E+11,
CS   2      -4.4615792982775076130E+03, 1.0650724020080236441E+01,
CS   3      -1.0767857011487300348E-02/
CS    DATA QJ0/5.9117614494174794095E+05, 2.0228375140097033958E+08,
CS   1       4.2091902282580133541E+10, 4.1868604460820175290E+12,
CS   2       1.0742272239517380498E+03/
      DATA PJ0/9.8062904098958257677D+05,-1.1548696764841276794D+08,
     1       6.6781041261492395835D+09,-1.4258509801366645672D+11,
     2      -4.4615792982775076130D+03, 1.0650724020080236441D+01,
     3      -1.0767857011487300348D-02/
      DATA QJ0/5.9117614494174794095D+05, 2.0228375140097033958D+08,
     1       4.2091902282580133541D+10, 4.1868604460820175290D+12,
     2       1.0742272239517380498D+03/
C-------------------------------------------------------------------
C  Coefficients for rational approximation of
C  J1(X) / (X * (X**2 - XJ1**2)),  4.0  <  |X|  <=  8.0
C-------------------------------------------------------------------
CS    DATA PJ1/4.6179191852758252280E+00,-7.1329006872560947377E+03,
CS   1       4.5039658105749078904E+06,-1.4437717718363239107E+09,
CS   2       2.3569285397217157313E+11,-1.6324168293282543629E+13,
CS   3       1.1357022719979468624E+14, 1.0051899717115285432E+15/
CS    DATA QJ1/1.1267125065029138050E+06, 6.4872502899596389593E+08,
CS   1       2.7622777286244082666E+11, 8.4899346165481429307E+13,
CS   2       1.7128800897135812012E+16, 1.7253905888447681194E+18,
CS   3       1.3886978985861357615E+03/
      DATA PJ1/4.6179191852758252280D+00,-7.1329006872560947377D+03,
     1       4.5039658105749078904D+06,-1.4437717718363239107D+09,
     2       2.3569285397217157313D+11,-1.6324168293282543629D+13,
     3       1.1357022719979468624D+14, 1.0051899717115285432D+15/
      DATA QJ1/1.1267125065029138050D+06, 6.4872502899596389593D+08,
     1       2.7622777286244082666D+11, 8.4899346165481429307D+13,
     2       1.7128800897135812012D+16, 1.7253905888447681194D+18,
     3       1.3886978985861357615D+03/
C-------------------------------------------------------------------
C  Coefficients for rational approximation of
C    (Y1(X) - 2 LN(X/XY0) J1(X)) / (X**2 - XY0**2),
C        XSMALL  <  |X|  <=  4.0
C--------------------------------------------------------------------
CS    DATA PY0/2.2157953222280260820E+05,-5.9157479997408395984E+07,
CS   1         7.2144548214502560419E+09,-3.7595974497819597599E+11,
CS   2         5.4708611716525426053E+12, 4.0535726612579544093E+13,
CS   3        -3.1714424660046133456E+02/
CS    DATA QY0/8.2079908168393867438E+02, 3.8136470753052572164E+05,
CS   1         1.2250435122182963220E+08, 2.7800352738690585613E+10,
CS   2         4.1272286200406461981E+12, 3.0737873921079286084E+14/
      DATA PY0/2.2157953222280260820D+05,-5.9157479997408395984D+07,
     1         7.2144548214502560419D+09,-3.7595974497819597599D+11,
     2         5.4708611716525426053D+12, 4.0535726612579544093D+13,
     3        -3.1714424660046133456D+02/
      DATA QY0/8.2079908168393867438D+02, 3.8136470753052572164D+05,
     1         1.2250435122182963220D+08, 2.7800352738690585613D+10,
     2         4.1272286200406461981D+12, 3.0737873921079286084D+14/
C--------------------------------------------------------------------
C  Coefficients for rational approximation of
C    (Y1(X) - 2 LN(X/XY1) J1(X)) / (X**2 - XY1**2),
C        4.0  <  |X|  <=  8.0
C--------------------------------------------------------------------
CS    DATA PY1/ 1.9153806858264202986E+06,-1.1957961912070617006E+09,
CS   1          3.7453673962438488783E+11,-5.9530713129741981618E+13,
CS   2          4.0686275289804744814E+15,-2.3638408497043134724E+16,
CS   3         -5.6808094574724204577E+18, 1.1514276357909013326E+19,
CS   4         -1.2337180442012953128E+03/
CS    DATA QY1/ 1.2855164849321609336E+03, 1.0453748201934079734E+06,
CS   1          6.3550318087088919566E+08, 3.0221766852960403645E+11,
CS   2          1.1187010065856971027E+14, 3.0837179548112881950E+16,
CS   3          5.6968198822857178911E+18, 5.3321844313316185697E+20/
      DATA PY1/ 1.9153806858264202986D+06,-1.1957961912070617006D+09,
     1          3.7453673962438488783D+11,-5.9530713129741981618D+13,
     2          4.0686275289804744814D+15,-2.3638408497043134724D+16,
     3         -5.6808094574724204577D+18, 1.1514276357909013326D+19,
     4         -1.2337180442012953128D+03/
      DATA QY1/ 1.2855164849321609336D+03, 1.0453748201934079734D+06,
     1          6.3550318087088919566D+08, 3.0221766852960403645D+11,
     2          1.1187010065856971027D+14, 3.0837179548112881950D+16,
     3          5.6968198822857178911D+18, 5.3321844313316185697D+20/
C-------------------------------------------------------------------
C  Coefficients for Hart,s approximation,  |X| > 8.0
C-------------------------------------------------------------------
CS    DATA P0/-1.0982405543459346727E+05,-1.5235293511811373833E+06,
CS   1         -6.6033732483649391093E+06,-9.9422465050776411957E+06,
CS   2         -4.4357578167941278571E+06,-1.6116166443246101165E+03/
CS    DATA Q0/-1.0726385991103820119E+05,-1.5118095066341608816E+06,
CS   1         -6.5853394797230870728E+06,-9.9341243899345856590E+06,
CS   2         -4.4357578167941278568E+06,-1.4550094401904961825E+03/
CS    DATA P1/ 1.7063754290207680021E+03, 1.8494262873223866797E+04,
CS   1          6.6178836581270835179E+04, 8.5145160675335701966E+04,
CS   2          3.3220913409857223519E+04, 3.5265133846636032186E+01/
CS    DATA Q1/ 3.7890229745772202641E+04, 4.0029443582266975117E+05,
CS   1          1.4194606696037208929E+06, 1.8194580422439972989E+06,
CS   2          7.0871281941028743574E+05, 8.6383677696049909675E+02/
      DATA P0/-1.0982405543459346727D+05,-1.5235293511811373833D+06,
     1         -6.6033732483649391093D+06,-9.9422465050776411957D+06,
     2         -4.4357578167941278571D+06,-1.6116166443246101165D+03/
      DATA Q0/-1.0726385991103820119D+05,-1.5118095066341608816D+06,
     1         -6.5853394797230870728D+06,-9.9341243899345856590D+06,
     2         -4.4357578167941278568D+06,-1.4550094401904961825D+03/
      DATA P1/ 1.7063754290207680021D+03, 1.8494262873223866797D+04,
     1          6.6178836581270835179D+04, 8.5145160675335701966D+04,
     2          3.3220913409857223519D+04, 3.5265133846636032186D+01/
      DATA Q1/ 3.7890229745772202641D+04, 4.0029443582266975117D+05,
     1          1.4194606696037208929D+06, 1.8194580422439972989D+06,
     2          7.0871281941028743574D+05, 8.6383677696049909675D+02/
C-------------------------------------------------------------------
C  Check for error conditions
C-------------------------------------------------------------------
      AX = ABS(ARG)
      IF ((JINT .EQ. 1) .AND. ((ARG .LE. ZERO) .OR.
     1   ((ARG .LT. HALF) .AND. (AX*XINF .LT. PI2)))) THEN
            RESULT = -XINF
            GO TO 2000
         ELSE IF (AX .GT. XMAX) THEN
            RESULT = ZERO
            GO TO 2000
      END IF
      IF (AX .GT. EIGHT) THEN
            GO TO 800
         ELSE IF (AX .LE. XSMALL) THEN
            IF (JINT .EQ. 0) THEN
                  RESULT = ARG * HALF
               ELSE
                  RESULT = -PI2 / AX
            END IF
            GO TO 2000
      END IF
C-------------------------------------------------------------------
C  Calculate J1 for appropriate interval, preserving
C     accuracy near the zero of J1
C-------------------------------------------------------------------
      ZSQ = AX * AX
      IF (AX .LE. FOUR) THEN
            XNUM = (PJ0(7) * ZSQ + PJ0(6)) * ZSQ + PJ0(5)
            XDEN = ZSQ + QJ0(5)
            DO 50 I = 1, 4
               XNUM = XNUM * ZSQ + PJ0(I)
               XDEN = XDEN * ZSQ + QJ0(I)
   50       CONTINUE
            PROD = ARG * ((AX - XJ01/TWO56) - XJ02) * (AX + XJ0)
         ELSE
            XNUM = PJ1(1)
            XDEN = (ZSQ + QJ1(7)) * ZSQ + QJ1(1)
            DO 220 I = 2, 6
               XNUM = XNUM * ZSQ + PJ1(I)
               XDEN = XDEN * ZSQ + QJ1(I)
  220       CONTINUE
            XNUM = XNUM * (AX - EIGHT) * (AX + EIGHT) + PJ1(7)
            XNUM = XNUM * (AX - FOUR) * (AX + FOUR) + PJ1(8)
            PROD = ARG * ((AX - XJ11/TWO56) - XJ12) * (AX + XJ1)
      END IF
      RESULT = PROD * (XNUM / XDEN)
      IF (JINT .EQ. 0) GO TO 2000
C-------------------------------------------------------------------
C  Calculate Y1.  First find  RESJ = pi/2 ln(x/xn) J1(x),
C    where xn is a zero of Y1
C-------------------------------------------------------------------
      IF (AX .LE. FOUR) THEN
            UP = (AX-XY01/TWO56)-XY02
            XY = XY0
         ELSE
            UP = (AX-XY11/TWO56)-XY12
            XY = XY1
      END IF
      DOWN = AX + XY
      IF (ABS(UP) .LT. P17*DOWN) THEN
            W = UP/DOWN
            WSQ = W*W
            XNUM = PLG(1)
            XDEN = WSQ + QLG(1)
            DO 320 I = 2, 4
               XNUM = XNUM*WSQ + PLG(I)
               XDEN = XDEN*WSQ + QLG(I)
  320       CONTINUE
            RESJ = PI2 * RESULT * W * XNUM/XDEN
         ELSE
            RESJ = PI2 * RESULT * LOG(AX/XY)
      END IF
C-------------------------------------------------------------------
C  Now calculate Y1 for appropriate interval, preserving
C     accuracy near the zero of Y1
C-------------------------------------------------------------------
      IF (AX .LE. FOUR) THEN
            XNUM = PY0(7) * ZSQ + PY0(1)
            XDEN = ZSQ + QY0(1)
            DO 340 I = 2, 6
               XNUM = XNUM * ZSQ + PY0(I)
               XDEN = XDEN * ZSQ + QY0(I)
  340       CONTINUE
         ELSE
            XNUM = PY1(9) * ZSQ + PY1(1)
            XDEN = ZSQ + QY1(1)
            DO 360 I = 2, 8
               XNUM = XNUM * ZSQ + PY1(I)
               XDEN = XDEN * ZSQ + QY1(I)
  360       CONTINUE
      END IF
      RESULT = RESJ + (UP*DOWN/AX) * XNUM / XDEN
      GO TO 2000
C-------------------------------------------------------------------
C  Calculate J1 or Y1 for |ARG|  >  8.0
C-------------------------------------------------------------------
  800 Z = EIGHT / AX
      W = AINT(AX/TWOPI) + THROV8
      W = (AX - W * TWOPI1) - W * TWOPI2
      ZSQ = Z * Z
      XNUM = P0(6)
      XDEN = ZSQ + Q0(6)
      UP = P1(6)
      DOWN = ZSQ + Q1(6)
      DO 850 I = 1, 5
         XNUM = XNUM * ZSQ + P0(I)
         XDEN = XDEN * ZSQ + Q0(I)
         UP = UP * ZSQ + P1(I)
         DOWN = DOWN * ZSQ + Q1(I)
  850 CONTINUE
      R0 = XNUM / XDEN
      R1 = UP / DOWN
      IF (JINT .EQ. 0) THEN
            RESULT = (RTPI2/SQRT(AX)) * (R0*COS(W) - Z*R1*SIN(W))
         ELSE
            RESULT = (RTPI2/SQRT(AX)) * (R0*SIN(W) + Z*R1*COS(W))
      END IF
      IF ((JINT .EQ. 0) .AND. (ARG .LT. ZERO)) RESULT = -RESULT
 2000 RETURN
C---------- Last card of CALJY1 ----------
      END


!-----------------------------------------------------------------------
function sigmav_ion(Te)
  implicit none
  double precision, parameter :: Tm=2.d0 !eV
  double precision :: sigmav_ion, Te, x,y
  if(Te .lt. Tm) then
     sigmav_ion = 0.d0
     return
  endif
  x = log(Te)
  y=-3.271396786375d+01+x*(1.353655609057d+01+x*(-5.739328757388d+00            &
    +x*(1.563154982022d+00+x*(-2.877056004391d-01+x*(3.482559773737d-02         &
    +x*(-2.631976175590d-03+x*(1.119543953861d-04+x*(-2.039149852002d-06))))))))
  sigmav_ion = exp(y)
 return
end function sigmav_ion
!-----------------------------------------------------------------------
!function sigmav_ion(Te)
!  implicit none
!  double precision :: sigmav_ion, Te, x, Tm=2.d0,  T0=20.d0 ! eV
!  if(Te .lt. Tm) then
!     sigmav_ion = 0.d0
!     return
!  endif
!  x = log10(Te)
!  if(Te .lt. T0) then
!    sigmav_ion = 1.d1**(-3.054d0*x - 1.572d1*exp(-x) + 1.603d0*exp(-x**2))
! else
!    sigmav_ion = 1.d1**(-5.151d-1*x -2.563d0/x - 5.231d0)
! endif
! return
!end function sigmav_ion
!-----------------------------------------------------------------------
function sigmav_cx(T)
  implicit none
  double precision :: sigmav_cx, T
  double precision, save ::  Tmin, Tmax, hm1, dt1, dt2
  logical, save :: firstcall=.true.
  integer, save :: nmin, nmax, ih
  integer :: i
  double precision, save, dimension(:), allocatable :: svcx

  if(firstcall) then
     firstcall = .false.
     open(1,file='cx.dat')
     read(1,*)nmin, nmax, ih
     Tmin = dble(nmin)
     Tmax = dble(nmax)
     hm1  = 1.d0/dble(ih)
     allocate(svcx(nmin:nmax))
     do i=nmin,nmax,ih
        read(1,*) svcx(i)
     enddo
     close(1)
  endif
  if(T .lt. Tmin) T = Tmin
  if(T .gt. Tmax) T = Tmax
  dt1 = (T - Tmin)*hm1
  i = int(dt1) + 1
  dt2 = dt1  + dble(1 - i)
  sigmav_cx = svcx(i) + (svcx(i+1) - svcx(i))*dt2
  return
end function sigmav_cx
!--------------------------------------------------------------


      SUBROUTINE MTXMUL2(AMAT,BMAT,CMAT,N1,N2,N3)
      IMPLICIT REAL*8(A-H,O-Z)
C
C  FOR N-BY-M MATRICS AMAT, BMAT, AND CMAT, FORM THE PRODUCT
C
C                 CMAT =  AMAT-TRANSPOSE * BMAT
C
C  VAR   DIM       TYPE   I/O   DESCRIPTION
C  ---   ---       ----   ---   -----------
C
C  AMAT  N2,N1     R*8    I     INPUT MATRIX.
C
C  BMAT  N2,N3     R*8    I     INPUT MATRIX.
C
C  CMAT  N1,N3     R*8    O     OUTPUT MATRIX. PRODUCT AMAT-TR * BMAT.
C                               NOTE THAT IN THE CALLING PROGRAM,
C                               CMAT MAY NOT BE ONE OF AMAT AND BMAT.
C                               THAT IS, THE CALL
C                               CALL MTXMUL2(A,B,A,.....) IS INVALID.
C
C  N1    1         I*4    I     NUMBER OF ROWS IN CMAT AND NUMBER OF
C                               COLUMNS IN AMAT.
C
C  N2    1         I*4    I     NUMBER OF ROWS IN AMAT AND NUMBER OF
C                               ROWS IN BMAT.
C
C  N3    1         I*4    I     NUMBER OF COLUMNS IN BMAT AND CMAT.
C
C
C***********************************************************************
C
C  CODED BY C PETRUZZO. 2/83.
C  MODIFIED............
C
C***********************************************************************
C
C
      REAL*8 AMAT(N2,N1),BMAT(N2,N3),CMAT(N1,N3)
C
      DO 100 I1=1,N1
      DO 100 I3=1,N3
      TEMP=0.D0
      DO 200 I2=1,N2
  200 TEMP=TEMP+AMAT(I2,I1)*BMAT(I2,I3)
  100 CMAT(I1,I3)=TEMP
C
      RETURN
      END


      subroutine resid_alphadyopl(n_K,n_alpha,np1_K,np1_alpha,x,Nx,ht,my
     &zero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 myzero
      real*8 n_K(Nx)
      real*8 n_alpha(Nx)
      real*8 np1_K(Nx)
      real*8 np1_alpha(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res
      real*8 qb
      res = 0.0D0
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = (-0.1D1 * n_alpha(i) + np1_alpha(i)) / ht + np1_alpha(i) * np
     #1_K(i) + n_alpha(i) * n_K(i)
      res = res + qb**2
      end do
      endif
      do i=2, Nx-1, 1
      qb = (-0.1D1 * n_alpha(i) + np1_alpha(i)) / ht + np1_alpha(i) * np
     #1_K(i) + n_alpha(i) * n_K(i)
      res = res + qb**2
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = np1_alpha(i) + myzero * x(i) - 0.1D1
      res = res + qb**2
      end do
      endif
      res = sqrt(res/(1*Nx))
      END


!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the 'Software'), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!

! Largest prime factor
!
! The prime factors of 13195 are 5, 7, 13 and 29.
! What is the largest prime factor of the number 600851475143 ?
module MPEProblem3

    implicit none
    private

    type, public :: TPEProblem3
    contains
        procedure, nopass :: present
    end type
contains
    subroutine present
        write (*, '(A)') 'Problem 3. Largest prime factor.'

        write (*, '(A, I)') 'Factor 1: ', factor()
    end subroutine

    function factor()
        integer*8 factor
        integer*8 index

        factor = 600851475143
        index  = 2

        do while ((index ** 2) .le. factor)
            if (mod(factor, index) .eq. 0) then
                factor = factor / index
            else
                index = index + 1
            end if
        end do
    end function
end module


!Autor: Claudio Iván Esparza Castañeda
!Título: División sintética
!Descripción: Se encarga de dividir un polinomio entre un binomio por el método de la división sintética
!Fecha: 19/03/2020

program DivSint !Inicio del programa
  implicit none !Sin variables implícitas
  REAL, allocatable, dimension(:)::a, b !Vector tipo REAL con dimensión dinámica
  REAL::p, d, x, r, s, t !Varibles tipo REAL
  INTEGER::i, n, m !Variables enteras
  d=0.0 !Inicializar valor de derivada
  p=0.0 !Inicializar valor de polinomio
  WRITE(*, *) "Grado del polinomio" !Preguntar por el grado del polinomio
  READ(*, *) n
  allocate(a(0:n), b(0:n-1)) !Asignar valor a variable dinámica
  WRITE(*, *) "Coeficientes del polinomio a0+a1x+a2x²+...anx^n" !Pregunta coeficientes del polinomio
  do i=0, n
     READ(*, *) a(i)
  end do
  WRITE(*, *) "t de (x-t) para dividir el  polinomio" !Preguntar valor para evaluar polinomio
  READ(*, *) t
  r=a(n) !Salvar el n-ésimo término del polinomio
  a(n)=0 !Hacer 0 el n-ésimo término del polinomio
  do i=n-1, 0, -1 !Para cada término del polinomio de atrás para adelante
     s=a(i) !Salvar el i-ésimo término del polinomio
     a(i)=r  !Tomar el valor del término anterior
     r=s+r*t !Sumar el i-ésimo término al producto del término anterior y el divisor
     b(i)=r !Salvar en un vector resultado
  end do
  do i=n-1, 0, -1
     WRITE(*, *) b(i) !Valores del vector resultado
  end do
  deallocate(a, b) !Liberar memoria dinámica
end program DivSint


program oscillator
use dftatom
implicit none

! Atomic number:
integer, parameter :: Z = 0
! Omega:
real(dp), parameter :: omega = 1.0_dp
! Mesh parameters:
real(dp), parameter :: r_min = 1e-8_dp, r_max = 10._dp, a = 80._dp
integer, parameter :: NN = 5000

real(dp), parameter :: c = 137.03599907_dp, eps = 1e-10_dp
integer :: n, n2, l, relat, converged, relat_max, k, kappa
real(dp) :: r(NN+1), u(size(r)), Ein, E, E_exact_nonrel, error, P(size(r)), &
    Q(size(r))
real(dp) :: Rp(NN+1)
real(dp) :: Emin_init, Emax_init
real(dp) :: E_exact(7, -7:7) ! E_exact(n, kappa)

E_exact = 0
E_exact(7, -7) = 7.4996755269_dp
E_exact(6:7, -6) = [ &
 6.4997620499_dp, &
 8.4994625812_dp &
]
E_exact(5:7, -5) = [ &
     5.4998352632_dp, &
     7.4995757160_dp, &
     9.4992363376_dp &
]
E_exact(4:7, -4) = [ &
     4.4998951661_dp, &
     6.4996755428_dp, &
     8.4993760822_dp, &
    10.4989967965_dp &
]
E_exact(3:7, -3) = [ &
     3.4999417582_dp, &
     5.4997620612_dp, &
     7.4995025208_dp, &
     9.4991631492_dp, &
    11.4987439585_dp &
]
E_exact(2:7, -2) = [ &
     2.4999750389_dp, &
     4.4998352706_dp, &
     6.4996156527_dp, &
     8.4993161976_dp, &
    10.4989369173_dp, &
    12.4984778242_dp &
]
E_exact(1:7, -1) = [ &
    1.4999950078_dp, &
    3.4998951705_dp, &
    5.4997154776_dp, &
    7.4994559413_dp, &
    9.4991165738_dp, &
    11.4986973873_dp, &
    13.4981983940_dp &
]
E_exact(2:7, 1) = [ &
     2.4999351051_dp, &
     4.4997953424_dp, &
     6.4995757249_dp, &
     8.4992762722_dp, &
    10.4988969952_dp, &
    12.4984379048_dp &
]
E_exact(3:7, 2) = [ &
     3.4998752033_dp, &
     5.4996955116_dp, &
     7.4994359765_dp, &
     9.4990966102_dp, &
    11.4986774249_dp &
]
E_exact(4:7, 3) = [ &
     4.4998019930_dp, &
     6.4995823772_dp, &
     8.4992829240_dp, &
    10.4989036457_dp &
]
E_exact(5:7, 4) = [ &
 5.4997154739_dp, &
 7.4994559363_dp, &
 9.4991165675_dp &
]
E_exact(6:7, 5) = [ &
 6.4996156467_dp, &
 8.4993161897_dp &
]
E_exact(7, 6) = 7.4995025118_dp

r = mesh_exp(r_min, r_max, a, NN)
Rp = mesh_exp_deriv(r_min, r_max, a, NN)
u = omega**2 * r**2 / 2

print *, "Relativistic linear spherically symmetric harmonic oscillator"
print *, "Mesh parameters (r_min, r_max, a, N):"
print "(ES10.2, F10.2, ES10.2, I10)", r_min, r_max, a, NN
print *
print *, " n  l  k kappa        E             E_exact     Error      E_exact_nonrel"
print *
do n = 1, 7
    do l = 0, n-1
        if (l == 0) then
            relat_max = 2
        else
            relat_max = 3
        end if
        do relat = 2, relat_max
            k = relat - 2
            if (k == 0) then
                kappa = -l - 1
            else
                kappa = l
            end if
            E_exact_nonrel = omega * (2*n - l - 1._dp/2)
            Ein = -100
            Emin_init = 0
            Emax_init = 100
            if (kappa > 0) then
                n2 = n + 1
            else
                n2 = n
            end if
            call solve_radial_eigenproblem(n2, l, Ein, eps, 100, R, Rp, u, &
                Z, c, relat, .false., Emin_init, Emax_init, converged, E, P, Q)
            error = abs(E - E_exact(n, kappa))
            if (converged /= 0) call stop_error("Not converged")
            print "(I3, I3, I3, I3, F17.8, F17.8, ES10.2, F17.8)", n, l, k, &
                kappa, E, E_exact(n, kappa), error, E_exact_nonrel
            if (error > 1e-8_dp) call stop_error("Error is higher than 1e-8")
        end do
    end do
end do
end program


program avg_path_test
use, intrinsic :: iso_fortran_env
use random_mod
use node_mod
implicit none
integer, parameter :: sp = REAL32
integer :: nr_trees = 1000
real(kind=sp), parameter :: init_prob = 1.0_sp, factor = 0.75_sp, &
                            root_dist = 0.0_sp
type(node_type) :: root
integer :: i
real(kind=sp) :: avg_path, avg_nodes
character(len=20) :: buffer

if (command_argument_count() > 0) then
    call get_command_argument(1, buffer)
    read (buffer, "(I10)") nr_trees
end if

! initialize the random number generator to get a unique sequence per run
call init_random_seed()

avg_path = 0.0_sp
avg_nodes = 0.0_sp
do i = 1, nr_trees
    ! create a tree where each node value
    ! denotes a distance between it, and its parent
    call root%init_random(init_prob, factor, root_dist)
    ! compute the number of nodes in the tree, and the longest apth
    avg_path = avg_path + root%leaf_distance()
    avg_nodes = avg_nodes + root%count_nodes()
    ! finalize to prevent memory leakes
    call root%finalize()
end do
avg_path = avg_path/nr_trees
avg_nodes = avg_nodes/nr_trees

! write results
write (unit=output_unit, fmt="(A, F6.3)") "avg. path = ", avg_path
write (unit=output_unit, fmt="(A, F6.2)") "avg. nodes = ", avg_nodes

end program avg_path_test


! $UWHPSC/codes/openmp/yeval.f90

! If this code gives a Segmentation Fault when compiled and run with -fopenmp
! Then you could try:
!   $ ulimit -s unlimited
! to increase the allowed stack size.
! This may not work on all computers.  On a Mac the best you can do is
!   $ ulimit -s hard
! Correction... you can do the following on a Mac:
!   $ gfortran -fopenmp -Wl,-stack_size,2faf2000 yeval.f90
! here 2faf2000 is a hexadecimal number slightly larger than 8e8, the
! number of bytes needed for the value of n used in this program.

program yeval

   use omp_lib
   implicit none
   integer, parameter :: n = 100000000
   integer :: i, nthreads
   real(kind=8), dimension(n) :: y
   real(kind=8) :: dx, x

   ! Specify number of threads to use:
   !$ print *, "How many threads to use? "
   !$ read *, nthreads
   !$ call omp_set_num_threads(nthreads)
   !$ print "('Using OpenMP with ',i3,' threads')", nthreads

   dx = 1.d0 / (n+1.d0)

   !$omp parallel do private(x)
   do i=1,n
      x = i*dx
      y(i) = exp(x)*cos(x)*sin(x)*sqrt(5*x+6.d0)
   enddo

   print *, "Filled vector y of length", n

end program yeval


      SUBROUTINE slPXY (NP,XYE,XYM,COEFFS,XYP,XRMS,YRMS,RRMS)
*+
*     - - - -
*      P X Y
*     - - - -
*
*  Given arrays of "expected" and "measured" [X,Y] coordinates, and a
*  linear model relating them (as produced by slFTXY), compute
*  the array of "predicted" coordinates and the RMS residuals.
*
*  Given:
*     NP       i        number of samples
*     XYE     d(2,np)   expected [X,Y] for each sample
*     XYM     d(2,np)   measured [X,Y] for each sample
*     COEFFS  d(6)      coefficients of model (see below)
*
*  Returned:
*     XYP     d(2,np)   predicted [X,Y] for each sample
*     XRMS     d        RMS in X
*     YRMS     d        RMS in Y
*     RRMS     d        total RMS (vector sum of XRMS and YRMS)
*
*  The model is supplied in the array COEFFS.  Naming the
*  elements of COEFF as follows:
*
*     COEFFS(1) = A
*     COEFFS(2) = B
*     COEFFS(3) = C
*     COEFFS(4) = D
*     COEFFS(5) = E
*     COEFFS(6) = F
*
*  the model is applied thus:
*
*     XP = A + B*XM + C*YM
*     YP = D + E*XM + F*YM
*
*  The residuals are (XP-XE) and (YP-YE).
*
*  If NP is less than or equal to zero, no coordinates are
*  transformed, and the RMS residuals are all zero.
*
*  See also slFTXY, slINVF, slXYXY, slDCMF
*
*  Called:  slXYXY
*
*  P.T.Wallace   Starlink   22 May 1996
*
*  Copyright (C) 1996 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      INTEGER NP
      DOUBLE PRECISION XYE(2,NP),XYM(2,NP),COEFFS(6),
     :                 XYP(2,NP),XRMS,YRMS,RRMS

      INTEGER I
      DOUBLE PRECISION SDX2,SDY2,XP,YP,DX,DY,DX2,DY2,P

*  Initialize summations
      SDX2=0D0
      SDY2=0D0

*  Loop by sample
      DO I=1,NP

*     Transform "measured" [X,Y] to "predicted" [X,Y]
         CALL slXYXY(XYM(1,I),XYM(2,I),COEFFS,XP,YP)
         XYP(1,I)=XP
         XYP(2,I)=YP

*     Compute residuals in X and Y, and update summations
         DX=XYE(1,I)-XP
         DY=XYE(2,I)-YP
         DX2=DX*DX
         DY2=DY*DY
         SDX2=SDX2+DX2
         SDY2=SDY2+DY2

*     Next sample
      END DO

*  Compute RMS values
      P=MAX(1D0,DBLE(NP))
      XRMS=SQRT(SDX2/P)
      YRMS=SQRT(SDY2/P)
      RRMS=SQRT(XRMS*XRMS+YRMS*YRMS)

      END


program beta
use statistical
implicit none

integer,parameter :: rs=8
real(rs) :: p,q,dp,dq

dp = 0.1_rs
dq = 0.1_rs

! Set up p and q so they are never integers
p = -3._rs + dp/2._rs
do while (p < 3._rs)
   q = -3._rs + dq/2._rs
   do while (q < 3._rs)
      write(*,*) p,q,beta_func(p,q)
      q = q + dq
   enddo
   p = p + dp
   write(*,*)  ! For gnuplot
enddo

end program beta


subroutine solid_normint_3d(x_solid,nsd,nn_solid,ien_sbc,ne_sbc,nen_solid,&
                        ien_solid,ne_solid,solid_norm)
!---------------------------------
! Calculate solid surface normal integral for 3-D cases
! 1 find the points on the boundary surface
! 2 use two vector cross to find the norm of the norm of the surface
! 3 take one interial point and take the dot between this vector and norm
!   if dot < 0 it is the outward norm and then normalize the norm
! 4 calculate the area of boundary surface: (1) tet, area of triangle; (2) hex, 2 triangles
! 5 take norm*area and distribute it equaly to the each node

implicit none

real(8) x_solid(nsd,nn_solid)
integer nsd
integer nn_solid
integer ien_sbc(ne_sbc,nen_solid+2)
integer ne_sbc
integer nen_solid
integer ien_solid(ne_solid,nen_solid)
integer ne_solid
real(8) solid_norm(nsd,nn_solid)
!------------------------------------
integer count
integer ibs
integer ine
integer ntem
integer nos
real(8), allocatable :: x(:,:)
real(8) p(nsd)
real(8) w
real(8) norm(nsd)
real(8) area
real(8) tot_area
solid_norm(:,:)=0.0d0
tot_area=0.0d0

if (nen_solid == 4) then
allocate (x(nsd,3))
w=1.0/3.0
end if

if (nen_solid == 8) then
allocate (x(nsd,4))
w=1.0/4.0
end if

do ibs=1,ne_sbc
	ine=ien_sbc(ibs,1)
	count=1
		do nos=1,nen_solid
		ntem=ien_solid(ine,nos)
		if (ien_sbc(ibs,nos+1) == 1) then
		x(1:nsd,count)=x_solid(1:nsd,ntem)
		count=count+1
		else
		p(1:nsd)=x_solid(1:nsd,ntem)
		end if
		end do

		if (nen_solid == 4) then
			call outnormal_tet(x,nsd,p,norm,area)
		else if (nen_solid == 8) then
			call outnormal_hex(x,nsd,p,norm,area)
		end if

		tot_area=area+tot_area
                do nos=1,nen_solid
                ntem=ien_solid(ine,nos)
                if (ien_sbc(ibs,nos+1) == 1) then
		solid_norm(:,ntem)=solid_norm(:,ntem)+area*norm(:)*w
		end if
		end do
continue

end do

!write(*,*) 'tot surface area', tot_area

deallocate(x)

end


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

    use qinit_module, only: qinit_type,add_perturbation
    use geoclaw_module, only: sea_level

    implicit none

    ! Subroutine arguments
    integer, intent(in) :: meqn,mbc,mx,my,maux
    real(kind=8), intent(in) :: xlower,ylower,dx,dy
    real(kind=8), intent(inout) :: q(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)
    real(kind=8), intent(inout) :: aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)

    ! Locals
    integer :: i, j
    real(kind=8) :: x, y, eta, h0

    ! Parameters
    real(kind=8) :: hmax, gamma, xs

    hmax = 0.0185d0
    gamma = sqrt(0.75d0 * hmax)
    xs = 38.d0

    ! Set soliton IC
    do i = 1 - mbc, mx + mbc
        x = xlower + (i - 0.5d0) * dx
        do j = 1 - mbc, my + mbc
            y = ylower + (j - 0.5d0) * dy
            eta = 4.d0 * hmax * (1.d0 / (exp(gamma * (x - xs)) + exp(-gamma * (x - xs))))**2
            q(1, i, j) = max(0.d0, eta - aux(1, i, j))
            h0 = max(0.d0, -aux(1, i, j))
            q(2, i, j) = q(1, i, j) * 2.d0 * (sqrt(h0) - sqrt(q(1, i, j)))
            q(3, i, j) = 0.d0
        end do
    end do

end subroutine qinit


subroutine discretize_var_ep(sigma2_varep,nzz,varep_grid,pr_varep)
    use nrtype
    implicit none
    real(SP),intent(in)::sigma2_varep
    integer,intent(in)::nzz
    real(SP),dimension(nzz,1)::varep_grid,pr_varep
    real(SP),dimension(nzz)::x
    integer::i_l
    real,dimension(nzz-1,1)::dz
    real(SP)::x1,x2,pr_1,pr_2

    if (nzz==2) then
        x=(/-0.7071067811,0.7071067811/)
    elseif (nzz==3) then
        x=(/-1.22474487139158,0.0,1.22474487139158/)
    elseif (nzz==4) then
        x=(/-1.650680123,-0.5246476232,0.5246476232,1.650680123/)
    elseif (nzz==5) then
        x=(/-2.02018287,-0.9585724646,0.0,0.9585724646,2.02018287/)
    elseif (nzz==7)then
        x=(/-2.65196135683523,-1.67355162876747,-0.816287882858964,0.0,0.816287882858964,1.67355162876747,2.65196135683523/)
    elseif(nzz==8)then
        x=(/-2.93063742025724,-1.98165675669584,-1.15719371244678,-0.381186990207322,0.381186990207322,1.15719371244678,1.98165675669584,2.93063742025724/)
    end if

    do i_l=1,nzz
        varep_grid(i_l,1)=sqrt(2.0d0)*sqrt(sigma2_varep)*x(i_l)
        if (i_l>1) then
            dz(i_l-1,1)=varep_grid(i_l,1)-varep_grid(i_l-1,1)
        end if
    end do

    if (sigma2_varep==0.0_sp)then
        pr_varep=1.0_sp/real(nzz)
    else
        i_l=1
        x1=(varep_grid(i_l,1)+dz(i_l,1)/2.0d0)/sqrt(sigma2_varep)
        pr_varep(i_l,1)=0.5d0+0.5d0*erf(x1/sqrt(2.0d0))

        i_l=nzz
        x1=(varep_grid(i_l,1)-dz(i_l-1,1)/2.0d0)/sqrt(sigma2_varep)
        pr_varep(i_l,1)=1.0d0-(0.5d0+0.5d0*erf(x1/sqrt(2.0d0)))

        do i_l=2,nzz-1
            x1=(varep_grid(i_l,1)-dz(i_l-1,1)/2d0)/sqrt(sigma2_varep)
            pr_1=0.5d0+0.5d0*erf(x1/sqrt(2.0d0))
            x2=(varep_grid(i_l,1)+dz(i_l,1)/2d0)/sqrt(sigma2_varep)
            pr_2=0.5d0+0.5d0*erf(x2/sqrt(2.0d0))
            pr_varep(i_l,1)=pr_2-pr_1
        end do
    end if

end subroutine


Real Function x2kaon(srt)
  Save
  smin = 2.8639
  x2kaon = 0.0000001
  If (srt<smin) Return
  sigma1 = 2.8
  sigma2 = 7.7
  sigma3 = 3.9
  x = srt**2/smin**2 + 0.0000001
  f1 = (1.+1./sqrt(x))*alog(x) - 4.*(1.-1./sqrt(x))
  f2 = 1. - (1./sqrt(x))*(1.+alog(sqrt(x)))
  f3 = ((x-1.)/x**2)**3.5
  x2kaon = (1.-1./x)**3*(sigma1*f1+sigma2*f2) + sigma3*f3
  Return
End Function x2kaon


!***********************************/
!	Name:次のモーションウェイト量の計算
!	Alias:OCalculateMotionWait
!	Description:衝撃波が1セル分通過するまで格子移動にウェイトを与える
!	Type:
!	Input:
!	Output:
!	Note:
!	Author:Akitaka Toyota
!	Date:2018.01.10
!	Update:
!	Other:
!***********************************/
subroutine OCalculateMotionWait(CC,UG,TimeStepWidth,MW,Geom)
    use StructVar_Mod
    use ConstantVar_Mod, Gamma => SpecificOfHeatRatio, CFL => CourantFriedrichsLewyCondition
    implicit none

    type(CellCenter), intent(in) :: CC
    type(UnstructuredGrid), intent(in) :: UG
    double precision, intent(in) :: TimeStepWidth
    type(MotionWait), intent(inout) :: MW
    type(Geometry), intent(in) :: Geom
    integer  :: iCell
    type(CalculateMotionWaitWithOMP) :: CMW
    integer :: iRequiredWait !衝撃波が通過するために必要なウェイト

    iRequiredWait = 0

!$omp parallel num_threads(CoreNumberOfCPU),shared(UG,CC,TimeStepWidth,Geom),firstprivate(iCell,CMW,iRequiredWait)
!$omp do reduction(max:iRequiredWait)
    do iCell = 1, UG%GI%RealCells
        CMW%AbsoluteVelocity2 = dot_product(CC%ConservedQuantity(2:4,iCell,1,1),CC%ConservedQuantity(2:4,iCell,1,1)) !速度L2ノルム

        CMW%LocalSoundSpeed = sqrt(Gamma*(Gmin1 * CC%ConservedQuantity(5,iCell,1,1) / CC%ConservedQuantity(1,iCell,1,1)) &
                            & + 0.5d0 * CMW%AbsoluteVelocity2) !局所音速

        CMW%AbsoluteVelocity = sqrt(CMW%AbsoluteVelocity2) !速度絶対値

        !CMW%ShockPassingTime = CFL * UG%DeltaXofCFLCondition / (CMW%LocalSoundSpeed + CMW%AbsoluteVelocity) !衝撃波が通過する速度
        !CMW%ShockPassingTime = CFL * sqrt(3.0d0)*UG%GM%AverageWidth(iCell) / (CMW%LocalSoundSpeed + CMW%AbsoluteVelocity) !衝撃波が通過する速度
        !CMW%ShockPassingTime = CFL * sqrt(3.0d0)*sqrt(Geom%Area(1)**2+Geom%Area(2)**2 / (CMW%LocalSoundSpeed + CMW%AbsoluteVelocity) !衝撃波が通過する速度
        CMW%ShockPassingTime = CFL * 2.0d0*max(Geom%Area(1),Geom%Area(2),UG%InscribedCircle(iCell)) / (CMW%LocalSoundSpeed + CMW%AbsoluteVelocity) !衝撃波が通過する速度

        iRequiredWait = max(iRequiredWait, int(CMW%ShockPassingTime/TimeStepWidth))

    end do
!$omp end do
!$omp end parallel

    MW%iMotionWait = iRequiredWait

return
end subroutine OCalculateMotionWait


  !> Test for mesh differentiation
Program example_2
  use Mirana
  implicit none
  integer, parameter :: n1 = 30, n2 = 50
  integer :: st1 = -3, st2 = -1, ed1, ed2
  double precision, parameter :: L = 1.5 !> A square domain
  double precision :: h1,h2,ej,exi1,exi2,eet1,eet2,x,y
  integer :: i,j
  double precision, dimension(:,:),allocatable :: mesh1,mesh2,jacob,xi1,xi2,et1,et2
  ed1 = st1 + n1 - 1
  ed2 = st2 + n2 - 1
  allocate(mesh1(st1:ed1,st2:ed2))
  allocate(mesh2(st1:ed1,st2:ed2))
  allocate(jacob(st1:ed1,st2:ed2))
  allocate(xi1(st1:ed1,st2:ed2))
  allocate(xi2(st1:ed1,st2:ed2))
  allocate(et1(st1:ed1,st2:ed2))
  allocate(et2(st1:ed1,st2:ed2))
  write(*,*) 'Hello, this is example_2, testing for mesh differentiation.'
  h1 = L / n1
  h2 = L / n2
  do i = st1,ed1
     do j = st2,ed2
        x = h1 * i - L/2
        y = h2 * j - L/2
        !> - The x-mesh \f$\xi=tanh(5x)\f$.
        !> - The y-mesh \f$\eta=tanh(y)\f$.
        mesh1(i,j) = 5 * atanh(x)
        mesh2(i,j) = atanh(y)
     end do
  end do

  call nmd(mesh1,mesh2,h1,h2,st1,st2,jacob,xi1,xi2,et1,et2)

  ej = 0
  exi1 = 0
  exi2 = 0
  eet1 = 0
  eet2 = 0
  do i = st1+1,ed1-1
     do j = st2+1,ed2-1
        x = h1 * i - L/2
        y = h2 * j - L/2
        exi1 = exi1 + abs( xi1(i,j) -  0.2 * (cosh(mesh1(i,j)/5.0)**(-2)) )
        exi2 = exi2 + abs( xi2(i,j) )
        eet1 = eet1 + abs( et1(i,j) )
        eet2 = eet2 + abs( et2(i,j) - cosh(mesh2(i,j))**(-2) )
     end do
  end do

  write(*,*) "==========================="
  write(*,*) "Error noms: "
  !write(*,*) "Jacobian: ", ej/n1/n2
  write(*,*) "xi_x: ", exi1/n1/n2
  write(*,*) "xi_y: ", exi2/n1/n2
  write(*,*) "eta_x: ", eet1/n1/n2
  write(*,*) "eta_y: ", eet2/n1/n2
  write(*,*) "==========================="

  call save_mesh(mesh1,mesh2,st1,st2)

  deallocate( mesh1 )
  deallocate( mesh2 )
  deallocate( jacob )
  deallocate( xi1 )
  deallocate( xi2 )
  deallocate( et1 )
  deallocate( et2 )
end Program example_2


Real Function aknpsg(pkaon)
  Save
  If (pkaon<=0.345) Then
    sigma1 = 0.624*pkaon**(-1.83)
  Else
    sigma1 = 0.7*pkaon**(-2.09)
  End If
  aknpsg = sigma1
  Return
End Function aknpsg


subroutine kernel(a,b,c, n, m, l, lb)
integer, intent(in) :: n,m,l,lb
integer :: a(lb:n,lb:m), b(lb:m, lb:l) , c(lb:n,lb:l)
integer :: example(2:10, 3:30)
integer :: i,j,k

do i = 1,n
  do j = 1,l
    c(i,j) = 0
    do k = 1,m
      c(i,j) = c(i,j) + a(i,k) * b(k,j)
    enddo
  enddo
enddo

end

subroutine matmul(n,m,l, lb)
integer, intent(in) :: n,m,l,lb
integer :: a(lb:n,lb:m), b(lb:m, lb:l) , c(lb:n,lb:l)
integer :: i,j,k, sumVal=0

do i = 1,m
  do j = 1,n
   a(i,j)= 1
  enddo
  do j = 1,l
   b(i,j)= 1
  enddo
enddo

call kernel(a,b,c,n,m,l,lb)

do i = 1,n
  do j = 1,l
   sumVal = sumVal + mod(c(i,j),10)
  enddo
enddo

print *, sumVal
end

program pgm
integer ::n,m,l, lb

lb = 1
n = 11
m = n
l = n
call matmul(n,m,l, lb)

end