! SPDX-Identifier: MIT

program test_stdlib_math
    use stdlib_math, only: clip
    use stdlib_error, only: check
    use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, qp
    implicit none

    ! clip function
    ! testing format: check(clip(x, xmin, xmax) == correct answer)
    ! valid case: xmin is not greater than xmax
    ! invalid case: xmin is greater than xmax

    ! type: integer(int8), kind: int8
    ! valid test case
    call check(clip(2_int8, -2_int8, 5_int8) == 2_int8, &
               'clip_int8 failed for valid case', warn=.true.)
    call check(clip(127_int8, -127_int8, 0_int8) == 0_int8, &
               'clip_int8 failed for valid case', warn=.true.)
    ! invalid test case
    call check(clip(2_int8, 5_int8, -2_int8) == 5_int8, &
               'clip_int8 failed for invalid case', warn=.true.)
    call check(clip(127_int8, 0_int8, -127_int8) == 0_int8, &
               'clip_int8 failed for invalid case', warn=.true.)

    ! type: integer(int16), kind: int16
    ! valid test case
    call check(clip(2_int16, -2_int16, 5_int16) == 2_int16, &
               'clip_int16 failed for valid case', warn=.true.)
    call check(clip(32767_int16, -32767_int16, 0_int16) == 0_int16, &
               'clip_int16 failed for valid case', warn=.true.)
    ! invalid test case
    call check(clip(2_int16, 5_int16, -2_int16) == 5_int16, &
               'clip_int16 failed for invalid case', warn=.true.)
    call check(clip(32767_int16, 0_int16, -32767_int16) == 0_int16, &
               'clip_int16 failed for invalid case', warn=.true.)

    ! type: integer(int32), kind: int32
    ! valid test case
    call check(clip(2_int32, -2_int32, 5_int32) == 2_int32, &
               'clip_int32 failed for valid case', warn=.true.)
    call check(clip(-2147483647_int32, 0_int32, 2147483647_int32) == 0_int32, &
               'clip_int32 failed for valid case', warn=.true.)
    ! invalid test case
    call check(clip(2_int32, 5_int32, -2_int32) == 5_int32, &
               'clip_int32 failed for invalid case', warn=.true.)
    call check(clip(-2147483647_int32, 2147483647_int32, 0_int32) == 2147483647_int32, &
               'clip_int32 failed for invalid case', warn=.true.)

    ! type: integer(int64), kind: int64
    ! valid test case
    call check(clip(2_int64, -2_int64, 5_int64) == 2_int64, &
               'clip_int64 failed for valid case', warn=.true.)
    call check(clip(-922337203_int64, -10_int64, 25_int64) == -10_int64, &
               'clip_int64 failed for valid case', warn=.true.)
    ! invalid test case
    call check(clip(2_int64, 5_int64, -2_int64) == 5_int64, &
               'clip_int64 failed for invalid case', warn=.true.)
    call check(clip(-922337203_int64, 25_int64, -10_int64) == 25_int64, &
               'clip_int64 failed for invalid case', warn=.true.)

    ! type: real(sp), kind: sp
    ! valid test case
    call check(clip(3.025_sp, -5.77_sp, 3.025_sp) == 3.025_sp, &
               'clip_sp failed for valid case', warn=.true.)
    call check(clip(0.0_sp, -1578.025_sp, -59.68_sp) == -59.68_sp, &
               'clip_sp failed for valid case', warn=.true.)
    ! invalid test case
    call check(clip(3.025_sp, 3.025_sp, -5.77_sp) == 3.025_sp, &
               'clip_sp failed for invalid case', warn=.true.)
    call check(clip(0.0_sp, -59.68_sp, -1578.025_sp) == -59.68_sp, &
               'clip_sp failed for invalid case', warn=.true.)

    ! type: real(dp), kind: dp
    ! valid test case
    call check(clip(3.025_dp, -5.77_dp, 3.025_dp) == 3.025_dp, &
               'clip_dp failed for valid case', warn=.true.)
    call check(clip(-7.0_dp, 0.059668_dp, 1.00268_dp) == 0.059668_dp, &
               'clip_dp failed for valid case', warn=.true.)
    ! invalid test case
    call check(clip(3.025_dp, 3.025_dp, -5.77_dp) == 3.025_dp, &
               'clip_dp failed for invalid case', warn=.true.)
    call check(clip(-7.0_dp, 1.00268_dp, 0.059668_dp) == 1.00268_dp, &
               'clip_dp failed for invalid case', warn=.true.)

    ! type: real(qp), kind: qp
    ! valid test case
    call check(clip(3.025_qp, -5.77_qp, 3.025_qp) == 3.025_qp, &
               'clip_qp failed for valid case', warn=.true.)
    call check(clip(-55891546.2_qp, -8958133457.23_qp, -689712245.23_qp) == -689712245.23_qp, &
               'clip_qp failed for valid case', warn=.true.)
    ! invalid test case
    call check(clip(3.025_qp, 3.025_qp, -5.77_qp) == 3.025_qp, &
               'clip_qp failed for invalid case', warn=.true.)
    call check(clip(-55891546.2_qp, -689712245.23_qp, -8958133457.23_qp) == -689712245.23_qp, &
               'clip_qp failed for invalid case', warn=.true.)

end program test_stdlib_math


      PROGRAM TEST
      USE FMZM
      USE FM_INTERVAL_ARITHMETIC

!  This program contains the code for the FM interval arithmetic examples that are discussed in
!  the paper "A Multiple-Precision Interval Arithmetic Package".

      IMPLICIT NONE

      INTEGER :: I, J, J_MAX, J_MIN, K, N, NF, K_FUNCTION, N_ORDER, N_STEPS, KPRT, KW, K_GRAPH,  &
                 BASE, N_PRECISION, DIGIT_COUNT(9)
      TYPE (FM_INTERVAL) :: A, B, RESULT, S, TERM, PI, C, X, Y, V(5), DET
      TYPE (FM_INTERVAL), ALLOCATABLE :: MATRIX(:,:), RHS(:), SOLN(:)
      INTEGER, ALLOCATABLE :: KSWAP(:)
      TYPE (FM) :: A_FM, B_FM, S_FM, PI_FM, C_FM, X_FM, Y_FM
      TYPE (FM) :: ERROR_FM, WIDTH_FM, LEAST_WIDTH_FM
      DOUBLE PRECISION :: RAND

!             Set the FM precision to 50 digits.

      CALL FM_SET(50)

!             Write output to file IntervalExamplesFM.out.
!             The FM_SETVAR call directs all output from within the FM package to unit 22 also.

      OPEN(22,FILE='IntervalExamplesFM.out')
      CALL FM_SETVAR(' KW = 22 ')

!             Unit 31 will be used to write several files that give the interval width
!             for each step of the different examples.

      K_GRAPH = 31

!             Example 1.  Ignoring variable correlation in formulas causes interval arithmetic
!                         to get too wide a resulting interval.

      WRITE (22,*) ' '
      WRITE (22,*) ' '
      WRITE (22,*) " Example 1.   Compute f(x) = X**2 - X + 3 using different formulas."
      WRITE (22,*) ' '

      X = TO_FM_INTERVAL( " -0.5 ", " 1.0 " )

      WRITE (22,*) ' '
      WRITE (22,*) ' X is the interval [ -0.5 , 1.0 ]'
      WRITE (22,*) ' '

      X_FM = 0.5
      A_FM = X_FM**2 - X_FM + 3
      X_FM = LEFT_ENDPOINT(X)
      B_FM = X_FM**2 - X_FM + 3
      LEAST_WIDTH_FM = B_FM - A_FM

      Y = X**2

      C_FM = (RIGHT_ENDPOINT(Y) - LEFT_ENDPOINT(Y)) / LEAST_WIDTH_FM
      WRITE (22,*) ' '
      WRITE (22,"(A,F6.3,A,F6.3,A)") ' X**2 gives  [ ',                   &
               TO_DP(LEFT_ENDPOINT(Y)), ' , ', TO_DP(RIGHT_ENDPOINT(Y)),  &
               ' ]'

      Y = X*X

      C_FM = (RIGHT_ENDPOINT(Y) - LEFT_ENDPOINT(Y)) / LEAST_WIDTH_FM
      WRITE (22,*) ' '
      WRITE (22,"(A,F6.3,A,F6.3,A)") ' X*X  gives  [ ',                   &
               TO_DP(LEFT_ENDPOINT(Y)), ' , ', TO_DP(RIGHT_ENDPOINT(Y)),  &
               ' ]'
      WRITE (22,*) ' '
      WRITE (22,*) ' '

      Y = X**2 - X + 3

      C_FM = (RIGHT_ENDPOINT(Y) - LEFT_ENDPOINT(Y)) / LEAST_WIDTH_FM
      WRITE (22,*) ' '
      WRITE (22,"(A,F6.3,A,F6.3,A,F6.3)") ' X**2 - X + 3        gives  [ ',  &
               TO_DP(LEFT_ENDPOINT(Y)), ' , ', TO_DP(RIGHT_ENDPOINT(Y)),     &
               ' ].   Magnification = ', TO_DP(C_FM)

      Y = X*X - X + 3

      C_FM = (RIGHT_ENDPOINT(Y) - LEFT_ENDPOINT(Y)) / LEAST_WIDTH_FM
      WRITE (22,*) ' '
      WRITE (22,"(A,F6.3,A,F6.3,A,F6.3)") ' X*X - X + 3         gives  [ ',  &
               TO_DP(LEFT_ENDPOINT(Y)), ' , ', TO_DP(RIGHT_ENDPOINT(Y)),     &
               ' ].   Magnification = ', TO_DP(C_FM)

      Y = X*(X - 1) + 3

      C_FM = (RIGHT_ENDPOINT(Y) - LEFT_ENDPOINT(Y)) / LEAST_WIDTH_FM
      WRITE (22,*) ' '
      WRITE (22,"(A,F6.3,A,F6.3,A,F6.3)") ' X*(X - 1) + 3       gives  [ ',  &
               TO_DP(LEFT_ENDPOINT(Y)), ' , ', TO_DP(RIGHT_ENDPOINT(Y)),     &
               ' ].   Magnification = ', TO_DP(C_FM)

      Y = (X - 0.5)**2 + 2.75

      C_FM = (RIGHT_ENDPOINT(Y) - LEFT_ENDPOINT(Y)) / LEAST_WIDTH_FM
      WRITE (22,*) ' '
      WRITE (22,"(A,F6.3,A,F6.3,A,F6.3)") ' (X - 0.5)**2 + 2.75 gives  [ ',  &
               TO_DP(LEFT_ENDPOINT(Y)), ' , ', TO_DP(RIGHT_ENDPOINT(Y)),     &
               ' ].   Magnification = ', TO_DP(C_FM)

      WRITE (22,*) ' '
      WRITE (22,*) ' '
      WRITE (22,*) ' '

!             Results are not as bad when the interval doesn't include zero.

      X = TO_FM_INTERVAL( " 0.1 ", " 1.0 " )

      WRITE (22,*) ' '
      WRITE (22,*) ' X is the interval [ 0.1 , 1.0 ]'
      WRITE (22,*) ' '

      X_FM = 0.5
      A_FM = X_FM**2 - X_FM + 3
      X_FM = RIGHT_ENDPOINT(X)
      B_FM = X_FM**2 - X_FM + 3
      LEAST_WIDTH_FM = B_FM - A_FM

      Y = X**2 - X + 3

      C_FM = (RIGHT_ENDPOINT(Y) - LEFT_ENDPOINT(Y)) / LEAST_WIDTH_FM
      WRITE (22,*) ' '
      WRITE (22,"(A,F6.3,A,F6.3,A,F6.3)") ' X**2 - X + 3        gives  [ ',  &
               TO_DP(LEFT_ENDPOINT(Y)), ' , ', TO_DP(RIGHT_ENDPOINT(Y)),     &
               ' ].   Magnification = ', TO_DP(C_FM)

      Y = X*X - X + 3

      C_FM = (RIGHT_ENDPOINT(Y) - LEFT_ENDPOINT(Y)) / LEAST_WIDTH_FM
      WRITE (22,*) ' '
      WRITE (22,"(A,F6.3,A,F6.3,A,F6.3)") ' X*X - X + 3         gives  [ ',  &
               TO_DP(LEFT_ENDPOINT(Y)), ' , ', TO_DP(RIGHT_ENDPOINT(Y)),     &
               ' ].   Magnification = ', TO_DP(C_FM)

      Y = X*(X - 1) + 3

      C_FM = (RIGHT_ENDPOINT(Y) - LEFT_ENDPOINT(Y)) / LEAST_WIDTH_FM
      WRITE (22,*) ' '
      WRITE (22,"(A,F6.3,A,F6.3,A,F6.3)") ' X*(X - 1) + 3       gives  [ ',  &
               TO_DP(LEFT_ENDPOINT(Y)), ' , ', TO_DP(RIGHT_ENDPOINT(Y)),     &
               ' ].   Magnification = ', TO_DP(C_FM)

      Y = (X - 0.5)**2 + 2.75

      C_FM = (RIGHT_ENDPOINT(Y) - LEFT_ENDPOINT(Y)) / LEAST_WIDTH_FM
      WRITE (22,*) ' '
      WRITE (22,"(A,F6.3,A,F6.3,A,F6.3)") ' (X - 0.5)**2 + 2.75 gives  [ ',  &
               TO_DP(LEFT_ENDPOINT(Y)), ' , ', TO_DP(RIGHT_ENDPOINT(Y)),     &
               ' ].   Magnification = ', TO_DP(C_FM)

      WRITE (22,*) ' '
      WRITE (22,*) ' '
      WRITE (22,*) ' '

!             Results are better when the interval doesn't include a local minimum.

      X = TO_FM_INTERVAL( " 0.9 ", " 1.0 " )

      WRITE (22,*) ' '
      WRITE (22,*) ' X is the interval [ 0.9 , 1.0 ]'
      WRITE (22,*) ' '

      X_FM = LEFT_ENDPOINT(X)
      A_FM = X_FM**2 - X_FM + 3
      X_FM = RIGHT_ENDPOINT(X)
      B_FM = X_FM**2 - X_FM + 3
      LEAST_WIDTH_FM = B_FM - A_FM

      Y = X**2 - X + 3

      C_FM = (RIGHT_ENDPOINT(Y) - LEFT_ENDPOINT(Y)) / LEAST_WIDTH_FM
      WRITE (22,*) ' '
      WRITE (22,"(A,F6.3,A,F6.3,A,F6.3)") ' X**2 - X + 3        gives  [ ',  &
               TO_DP(LEFT_ENDPOINT(Y)), ' , ', TO_DP(RIGHT_ENDPOINT(Y)),     &
               ' ].   Magnification = ', TO_DP(C_FM)

      Y = X*X - X + 3

      C_FM = (RIGHT_ENDPOINT(Y) - LEFT_ENDPOINT(Y)) / LEAST_WIDTH_FM
      WRITE (22,*) ' '
      WRITE (22,"(A,F6.3,A,F6.3,A,F6.3)") ' X*X - X + 3         gives  [ ',  &
               TO_DP(LEFT_ENDPOINT(Y)), ' , ', TO_DP(RIGHT_ENDPOINT(Y)),     &
               ' ].   Magnification = ', TO_DP(C_FM)

      Y = X*(X - 1) + 3

      C_FM = (RIGHT_ENDPOINT(Y) - LEFT_ENDPOINT(Y)) / LEAST_WIDTH_FM
      WRITE (22,*) ' '
      WRITE (22,"(A,F6.3,A,F6.3,A,F6.3)") ' X*(X - 1) + 3       gives  [ ',  &
               TO_DP(LEFT_ENDPOINT(Y)), ' , ', TO_DP(RIGHT_ENDPOINT(Y)),     &
               ' ].   Magnification = ', TO_DP(C_FM)

      Y = (X - 0.5)**2 + 2.75

      C_FM = (RIGHT_ENDPOINT(Y) - LEFT_ENDPOINT(Y)) / LEAST_WIDTH_FM
      WRITE (22,*) ' '
      WRITE (22,"(A,F6.3,A,F6.3,A,F6.3)") ' (X - 0.5)**2 + 2.75 gives  [ ',  &
               TO_DP(LEFT_ENDPOINT(Y)), ' , ', TO_DP(RIGHT_ENDPOINT(Y)),     &
               ' ].   Magnification = ', TO_DP(C_FM)

      WRITE (22,*) ' '
      WRITE (22,*) ' '
      WRITE (22,*) ' '

!             Look at an even smaller interval

      X = TO_FM_INTERVAL( " 0.99 ", " 1.0 " )

      WRITE (22,*) ' '
      WRITE (22,*) ' X is the interval [ 0.99 , 1.0 ]'
      WRITE (22,*) ' '

      X_FM = LEFT_ENDPOINT(X)
      A_FM = X_FM**2 - X_FM + 3
      X_FM = RIGHT_ENDPOINT(X)
      B_FM = X_FM**2 - X_FM + 3
      LEAST_WIDTH_FM = B_FM - A_FM

      Y = X**2 - X + 3

      C_FM = (RIGHT_ENDPOINT(Y) - LEFT_ENDPOINT(Y)) / LEAST_WIDTH_FM
      WRITE (22,*) ' '
      WRITE (22,"(A,F6.3,A,F6.3,A,F6.3)") ' X**2 - X + 3        gives  [ ',  &
               TO_DP(LEFT_ENDPOINT(Y)), ' , ', TO_DP(RIGHT_ENDPOINT(Y)),     &
               ' ].   Magnification = ', TO_DP(C_FM)

      Y = X*X - X + 3

      C_FM = (RIGHT_ENDPOINT(Y) - LEFT_ENDPOINT(Y)) / LEAST_WIDTH_FM
      WRITE (22,*) ' '
      WRITE (22,"(A,F6.3,A,F6.3,A,F6.3)") ' X*X - X + 3         gives  [ ',  &
               TO_DP(LEFT_ENDPOINT(Y)), ' , ', TO_DP(RIGHT_ENDPOINT(Y)),     &
               ' ].   Magnification = ', TO_DP(C_FM)

      Y = X*(X - 1) + 3

      C_FM = (RIGHT_ENDPOINT(Y) - LEFT_ENDPOINT(Y)) / LEAST_WIDTH_FM
      WRITE (22,*) ' '
      WRITE (22,"(A,F6.3,A,F6.3,A,F6.3)") ' X*(X - 1) + 3       gives  [ ',  &
               TO_DP(LEFT_ENDPOINT(Y)), ' , ', TO_DP(RIGHT_ENDPOINT(Y)),     &
               ' ].   Magnification = ', TO_DP(C_FM)

      Y = (X - 0.5)**2 + 2.75

      C_FM = (RIGHT_ENDPOINT(Y) - LEFT_ENDPOINT(Y)) / LEAST_WIDTH_FM
      WRITE (22,*) ' '
      WRITE (22,"(A,F6.3,A,F6.3,A,F6.3)") ' (X - 0.5)**2 + 2.75 gives  [ ',  &
               TO_DP(LEFT_ENDPOINT(Y)), ' , ', TO_DP(RIGHT_ENDPOINT(Y)),     &
               ' ].   Magnification = ', TO_DP(C_FM)
      WRITE (22,*) ' '

!             Example 2.  Sum  1 / n^7  from 1 to 100,000.

      OPEN(K_GRAPH,FILE='INTERVAL_EXAMPLES Sum')

      WRITE (K_GRAPH,"(//A//)") 'Example 2.  Sum  1 / n^7  from 1 to 100,000.'

      N = 10**5
      S = 0
      DO J = 1, N
         TERM = J
         S = S + 1 / TERM**7
         IF (MOD(J,N/1000) == 1) THEN
             WIDTH_FM = MAX( RIGHT_ENDPOINT(S)-LEFT_ENDPOINT(S) , EPSILON(LEFT_ENDPOINT(S)) )
             WRITE (K_GRAPH,"(A,I7,A,F8.3,A)") '{', J, ',', TO_DP(LOG(WIDTH_FM)) / LOG(10.0D0), '},'
         ENDIF
      ENDDO

      WRITE (22,*) ' '
      WRITE (22,*) " Example 2.  Sum  1 / n^7  from 1 to 100,000 ="
      CALL FMPRINT_INTERVAL(S)
      WRITE (22,*) ' '
      ERROR_FM = ABS( (RIGHT_ENDPOINT(S)-LEFT_ENDPOINT(S)) / RIGHT_ENDPOINT(S) )
      J = -NINT(LOG10(ERROR_FM))
      WRITE (22,"(A,I3,A)") '      The two endpoints agree to about',J,' decimal digits.'
      WRITE (22,*) ' '
      CLOSE(K_GRAPH)

!             Example 3.  Use composite 9-point Gauss quadrature with 1,000 subintervals
!                         to integrate  sin(t) / t  from  t = 0  to  t = 20.

      OPEN(K_GRAPH,FILE='INTERVAL_EXAMPLES Integration')

      WRITE (K_GRAPH,"(//A//)")  &
             'Example 3.  Use composite 9-point Gauss quadrature with 1,000 subintervals'

      NF = 1
      N = 1000
      A = 0
      B = 20
      CALL GAUSS_9(NF, A, B, N, RESULT)

      WRITE (22,*) ' '
      WRITE (22,*) " Example 3.  Integrate  sin(t) / t  from  t = 0  to  t = 20:"
      CALL FMPRINT_INTERVAL(RESULT)
      WRITE (22,*) ' '
      ERROR_FM = ABS( (RIGHT_ENDPOINT(RESULT)-LEFT_ENDPOINT(RESULT)) / RIGHT_ENDPOINT(RESULT) )
      J = -NINT(LOG10(ERROR_FM))
      WRITE (22,"(A,I3,A)") '      The two endpoints agree to about',J,' decimal digits.'
      WRITE (22,*) ' '
      CLOSE(K_GRAPH)

!             Example 4.  Start with  ( x, y ) = ( 1, 0 )  and step around the unit circle
!                         using the recurrence ( x, y ) <-- ( x*c - y*d, y*c + x*d ),
!                         c = cos(2*pi/n) and  s = sin(2*pi/n)

!                         After 23 trips around the circle with 100 steps per trip,
!                         x = ( -58.6 , 60.6 )  and  y = ( -59.6 , 59.6 )

!                         After 21 trips around the circle with 1000 steps per trip,
!                         x = ( 0.49 , 1.51 )  and  y = ( -0.51 , 0.51 )

      OPEN(K_GRAPH,FILE='INTERVAL_EXAMPLES Circle Recurrence')

      WRITE (K_GRAPH,"(//A//)")  &
             'Example 4.  Start with  ( x, y ) = ( 1, 0 )  and step around the unit circle'

      N = 100
      X = 1
      Y = 0
      PI = ACOS(TO_FM(-1))
      C = COS(2*PI/N)
      S = SIN(2*PI/N)

      WRITE (22,*) ' '
      WRITE (22,*) " Example 4.  Step around the unit circle multiple times using a recurrence"
      WRITE (22,*) ' '

      DO K = 1, 23
         DO J = 1, N
            A = X*C - Y*S
            B = Y*C + X*S
            X = A
            Y = B
            WIDTH_FM = MAX( RIGHT_ENDPOINT(X)-LEFT_ENDPOINT(X) , EPSILON(LEFT_ENDPOINT(X))/10**7 )
            WRITE (K_GRAPH,"(A,I7,A,F8.3,A)") '{', N*(K-1)+J,  &
                                              ',', TO_DP(LOG(WIDTH_FM)) / LOG(10.0D0), '},'
         ENDDO
         ERROR_FM = ABS( (RIGHT_ENDPOINT(X)-LEFT_ENDPOINT(X)) / RIGHT_ENDPOINT(X) )
         J = -NINT(LOG10(ERROR_FM))
         WRITE (22,"(I4,A,I3,A)") K,' trips.  The two endpoints for x agree to about',  &
                                 J,' decimal digits.'
      ENDDO

      WRITE (22,*) ' '
      WRITE (22,*) ' X ='
      CALL FMPRINT_INTERVAL(X)
      WRITE (22,*) ' '
      WRITE (22,*) ' Y ='
      CALL FMPRINT_INTERVAL(Y)
      WRITE (22,*) ' '
      ERROR_FM = ABS( (RIGHT_ENDPOINT(X)-LEFT_ENDPOINT(X)) / RIGHT_ENDPOINT(X) )
      J = -NINT(LOG10(ERROR_FM))
      WRITE (22,"(A,I3,A)") '      The two endpoints for x agree to about',J,' decimal digits.'
      WRITE (22,*) ' '

!                         Compare the same calculation in ordinary FM arithmetic.

!                         After 23 trips around the circle with 100 steps per trip,
!                         x = 1.0 to 60 digits  and  y = -2.3e-55

!                         After 23 trips around the circle with 1000 steps per trip,
!                         x = 1.0 exactly  and  y = -2.3e-55

      WRITE (22,*) ' '
      WRITE (22,*) ' Compare the same calculation in ordinary FM arithmetic.'
      WRITE (22,*) ' '
      N = 100
      X_FM = 1
      Y_FM = 0
      PI_FM = ACOS(TO_FM(-1))
      C_FM = COS(2*PI_FM/N)
      S_FM = SIN(2*PI_FM/N)

      DO K = 1, 23
         DO J = 1, N
            A_FM = X_FM*C_FM - Y_FM*S_FM
            B_FM = Y_FM*C_FM + X_FM*S_FM
            X_FM = A_FM
            Y_FM = B_FM
         ENDDO
         ERROR_FM = ABS( X_FM - 1 ) + TO_FM(' 1.0e-99 ')
         J = -NINT(LOG10(ERROR_FM))
         WRITE (22,"(I4,A,I3,A)") K,' trips.  x agrees with 1.0 to about',  &
                                 J,' decimal digits.'
      ENDDO

      WRITE (22,*) ' '
      WRITE (22,*) ' X ='
      CALL FM_PRINT(X_FM)
      WRITE (22,*) ' '
      WRITE (22,*) ' Y ='
      CALL FM_PRINT(Y_FM)
      WRITE (22,*) ' '
      CLOSE(K_GRAPH)

!             Test to see if it is x and y oscillating between positive and negative values
!             that causes the exponential growth of interval width, or if oscillation through
!             positive values alone can cause it.

!             Use the recurrence it oscillate back and forth between step number 8 and
!             step number 18 of the original recurrence.
!             Once back and forth takes 20 steps, so 5*23 = 115 trips back and forth will
!             take the same number of steps as the 23 trips around the circle above.

      OPEN(K_GRAPH,FILE='INTERVAL_EXAMPLES Back and Forth Recurrence')

      WRITE (K_GRAPH,"(//A/A//)")  &
             'Example 4b.  Start with  ( x, y ) = ( cos( 8* 2*pi/n), sin( 8* 2*pi/n) ) ',  &
             ' and step around the unit circle to ( cos(18* 2*pi/n), sin(18* 2*pi/n) ) and back'

      WRITE (22,*) ' '
      WRITE (22,*) " Example 4b.  Step back and forth around the unit circle using a recurrence"
      WRITE (22,*) ' '

      N = 100
      PI = ACOS(TO_FM(-1))
      X = COS(8* 2*PI/N)
      Y = SIN(8* 2*PI/N)
      C = COS(2*PI/N)
      S = SIN(2*PI/N)

      WRITE (22,*) ' '
      WRITE (22,*) ' Starting point for X ='
      CALL FMPRINT_INTERVAL(X)
      WRITE (22,*) ' '
      WRITE (22,*) ' Starting point for Y ='
      CALL FMPRINT_INTERVAL(Y)
      WRITE (22,*) ' '

!             5 back and forth trips equals 100 steps, the same as one circle trip above.

      DO K = 1, 23 * 5
         DO J = 1, 20
            A = X*C - Y*S
            B = Y*C + X*S
            X = A
            Y = B
            WIDTH_FM = MAX( RIGHT_ENDPOINT(X)-LEFT_ENDPOINT(X) , EPSILON(LEFT_ENDPOINT(X))/10**7 )
            WRITE (K_GRAPH,"(A,I7,A,F8.3,A)") '{', (20*(K-1)+J),  &
                                              ',', TO_DP(LOG(WIDTH_FM)) / LOG(10.0D0), '},'

            IF (MOD(J,10) == 0) THEN
                S = -S
            ENDIF
         ENDDO
         IF (MOD(K,5) == 0) THEN
             ERROR_FM = ABS( (RIGHT_ENDPOINT(X)-LEFT_ENDPOINT(X)) / RIGHT_ENDPOINT(X) )
             J = -NINT(LOG10(ERROR_FM))
             WRITE (22,"(I4,A,I3,A)") K,' trips.  The two endpoints for x agree to about',  &
                                     J,' decimal digits.'
         ENDIF
      ENDDO

      WRITE (22,*) ' '
      WRITE (22,*) ' X ='
      CALL FMPRINT_INTERVAL(X)
      WRITE (22,*) ' '
      WRITE (22,*) ' Y ='
      CALL FMPRINT_INTERVAL(Y)
      WRITE (22,*) ' '
      ERROR_FM = ABS( (RIGHT_ENDPOINT(X)-LEFT_ENDPOINT(X)) / RIGHT_ENDPOINT(X) )
      J = -NINT(LOG10(ERROR_FM))
      WRITE (22,"(A,I3,A)") '      The two endpoints for x agree to about',J,' decimal digits.'
      WRITE (22,*) ' '
      CLOSE(K_GRAPH)

!             Example 5.  2 * Product  4*n^2 / (4*n^2-1)  from 1 to 10,000.

      OPEN(K_GRAPH,FILE='INTERVAL_EXAMPLES Product')

      WRITE (K_GRAPH,"(//A//)")  &
             'Example 5.  2 * Product  4*n^2 / (4*n^2-1)  from 1 to 10,000.'

      N = 10**4
      S = 2
      DO J = 1, N
         K = 4 * J * J
         TERM = K
         TERM = TERM / ( K - 1 )
         S = S * TERM
         IF (MOD(J,N/1000) == 1) THEN
             WIDTH_FM = MAX( RIGHT_ENDPOINT(S)-LEFT_ENDPOINT(S) , EPSILON(LEFT_ENDPOINT(S)) )
             WRITE (K_GRAPH,"(A,I7,A,F8.3,A)") '{', J, ',', TO_DP(LOG(WIDTH_FM)) / LOG(10.0D0), '},'
         ENDIF
      ENDDO

      WRITE (22,*) ' '
      WRITE (22,*) " Example 5.  2 * Product  4*n^2 / (4*n^2-1)  from 1 to 10,000. ="
      CALL FMPRINT_INTERVAL(S)
      WRITE (22,*) ' '
      ERROR_FM = ABS( (RIGHT_ENDPOINT(S)-LEFT_ENDPOINT(S)) / RIGHT_ENDPOINT(S) )
      J = -NINT(LOG10(ERROR_FM))
      WRITE (22,"(A,I3,A)") '      The two endpoints of y(30) agree to about',J,' decimal digits.'
      WRITE (22,*) ' '

!             Example 6.  Differential equation.  y'' = -y' / 10  -  2 * y / (x+2),
!                                                 y(0) = 0,   y'(0) = 1

!                         This solution has 2 roots between 0 and 30.

      OPEN(K_GRAPH,FILE='INTERVAL_EXAMPLES Diff Eq 1')

      WRITE (K_GRAPH,"(//A//)")  &
             "Example 6.  Differential equation.  y'' = -y' / 10  -  2 * y / (x+2),"

      WRITE (22,*) ' '
      WRITE (22,*) " Example 6.  Differential equation.  y'' = -y' / 10  -  2 * y / (x+2)"
      WRITE (22,*) ' '
      N_ORDER = 2
      A = 0
      B = 30
      N_STEPS = 10000
      V(1) = 0
      V(2) = 1
      K_FUNCTION = 1
      KPRT = N_STEPS / 10
      KW = 22
      CALL RK4(N_ORDER, A, B, N_STEPS, V, K_FUNCTION, KPRT, KW)
      WRITE (22,*) ' '
      WRITE (22,*) ' y(30) = '
      WRITE (22,*) ' '
      CALL FMPRINT_INTERVAL(V(1))
      WRITE (22,*) ' '
      WRITE (22,*) " y'(30) = "
      WRITE (22,*) ' '
      CALL FMPRINT_INTERVAL(V(2))
      WRITE (22,*) ' '
      ERROR_FM = ABS( (RIGHT_ENDPOINT(V(1))-LEFT_ENDPOINT(V(1))) / RIGHT_ENDPOINT(V(1)) )
      J = -NINT(LOG10(ERROR_FM))
      WRITE (22,"(A,I3,A)") '      The two endpoints of y(30) agree to about',J,' decimal digits.'
      WRITE (22,*) ' '

!             Example 7.  Differential equation.  y'' = -y' / 10  -  200 * y / (x+2),
!                                                 y(0) = 0,   y'(0) = 1

!                         This solution has 38 roots between 0 and 30.
!                         The rapid oscillation causes the interval calculation to be unstable
!                         and lose accuracy in a manner similar to example 4, the stepping
!                         recurrence making multiple trips around the unit circle.

      OPEN(K_GRAPH,FILE='INTERVAL_EXAMPLES Diff Eq 2')

      WRITE (K_GRAPH,"(//A//)")  &
             "Example 7.  Differential equation.  y'' = -y' / 10  -  200 * y / (x+2),"

      WRITE (22,*) ' '
      WRITE (22,*) " Example 7.  Differential equation.  y'' = -y' / 10  -  200 * y / (x+2)"
      WRITE (22,*) ' '
      N_ORDER = 2
      A = 0
      B = 30
      N_STEPS = 10000
      V(1) = 0
      V(2) = 1
      K_FUNCTION = 2
      KPRT = N_STEPS / 10
      KW = 22
      CALL RK4(N_ORDER, A, B, N_STEPS, V, K_FUNCTION, KPRT, KW)
      WRITE (22,*) ' '
      WRITE (22,*) ' y(30) = '
      WRITE (22,*) ' '
      CALL FMPRINT_INTERVAL(V(1))
      WRITE (22,*) ' '
      WRITE (22,*) " y'(30) = "
      WRITE (22,*) ' '
      CALL FMPRINT_INTERVAL(V(2))
      WRITE (22,*) ' '
      ERROR_FM = ABS( (RIGHT_ENDPOINT(V(1))-LEFT_ENDPOINT(V(1))) / RIGHT_ENDPOINT(V(1)) )
      J = -NINT(LOG10(ERROR_FM))
      WRITE (22,"(A,I3,A)") '      The two endpoints of y(30) agree to about',J,' decimal digits.'
      WRITE (22,*) ' '
      CLOSE(K_GRAPH)

!             Example 8.  Solve a "random" NxN linear system.

      WRITE (22,*) ' '
      WRITE (22,*) ' Example 8.  Solve a "random" NxN linear system.'
      WRITE (22,*) ' '

      DO N = 10, 100, 10

         ALLOCATE( MATRIX(N,N), RHS(N), SOLN(N), KSWAP(N) )
         DO I = 1, N
            DO J = 1, N
               CALL FM_RANDOM_NUMBER(RAND)
               MATRIX(I,J) = RAND
            ENDDO
            RHS(I) = I
         ENDDO

         CALL FM_INTERVAL_FACTOR_LU(MATRIX, N, DET, KSWAP)
         CALL FM_INTERVAL_SOLVE_LU (MATRIX, N, RHS, SOLN, KSWAP)

         WRITE (22,*) ' '
         J_MIN = 99
         J_MAX = 0
         DO I = 1, N
            ERROR_FM = ABS( (RIGHT_ENDPOINT(SOLN(I))-LEFT_ENDPOINT(SOLN(I))) /  &
                             RIGHT_ENDPOINT(SOLN(I)) )
            J = -NINT(LOG10(ERROR_FM))
            J_MIN = MIN( J_MIN, J )
            J_MAX = MAX( J_MAX, J )
         ENDDO
         WRITE (22,"(A,I3,A,I3,A,I3,A)") ' For N = ', N,                              &
                                         ' the solution elements agree to between ',  &
                                         J_MIN, ' and ', J_MAX, ' significant digits.'

         DEALLOCATE( MATRIX, RHS, SOLN, KSWAP )
      ENDDO

!             Example 9.  Newton's method starting with a single point.  Solve  x*exp(x) - 2 = 0.

      WRITE (22,*) ' '
      WRITE (22,*) ' '
      WRITE (22,*) " Example 9.  Newton's method starting with a single point."
      WRITE (22,*) ' '

      X = 1
      DO J = 1, 10
         A = X*EXP(X) - 2
         B = (X+1)*EXP(X)
         X = X - A/B
         WRITE (22,*) ' '
         WRITE (22,"(A,I2,A)") " Iteration ",J,'.  X ='
         CALL FMPRINT_INTERVAL(X)
      ENDDO

!             Example 10.  Newton's method starting with an interval containing a root.
!                          Solve  x*exp(x) - 2 = 0.
!                          The next interval is xt - f(xt)/f'(x) intersected with x.
!                          xt is a single point from the interval x (the midpoint is used here).
!                          The idea is to have a contracting sequence of intervals that
!                          each contain a root.
!                          Refs:  Hansen-Greenberg 83, Baker Kearfott 95-97,
!                                 Mayer 95, van Hentenryck et al. 97

      WRITE (22,*) ' '
      WRITE (22,*) ' '
      WRITE (22,*) " Example 10.   Newton's method starting with an interval containing a root"
      WRITE (22,*) ' '

      X = TO_FM_INTERVAL( " 0.5 ", " 1.0 " )
      DO J = 1, 9
         X_FM = LEFT_ENDPOINT(X)/2 + RIGHT_ENDPOINT(X)/2
         Y_FM = X_FM*EXP(X_FM) - 2
         B = (X+1)*EXP(X)
         Y = X_FM - Y_FM/B

         X = TO_FM_INTERVAL( MAX( LEFT_ENDPOINT(X),LEFT_ENDPOINT(Y) ) ,  &
                             MIN( RIGHT_ENDPOINT(X),RIGHT_ENDPOINT(Y) ) )
         WRITE (22,*) ' '
         WRITE (22,"(A,I2,A)") " Iteration ",J,'.  X ='
         CALL FMPRINT_INTERVAL(X)
      ENDDO

!             Example 11.  Check "Benford's Law", a result about the distribution of the
!                          leading digits is sets of numerical data.
!                          Count the exact number of leading digits 1, 2, ..., 9 found
!                          in the first billion powers of base = 2, 3, 5.
!                          Ref:  "The Surprising Accuracy of Benford's Law in Mathematics",
!                                Zhaodong Cai, Matthew Faust, A. J. Hildebrand, Junxian Li,
!                                and Yuan Zhang -- American Mathematical Monthly, March 2020.

      BASE = 2

      WRITE (22,"(//A,I2/)") ' Example 11.   Count leading digits of powers of', BASE

      N = 10**9
      N_PRECISION = 20
      CALL FM_SET(N_PRECISION)

      DIGIT_COUNT = 0
      X = 1
      DO J = 1, N
         X = X * BASE

!             Check that the two endpoints of the interval have the same leading digit.
!             If so, that proves we have computed the correct leading digit.
!             If not, write a message about needing higher precision and stop.

         A_FM = LEFT_ENDPOINT(X)
         B_FM = RIGHT_ENDPOINT(X)

!             In this comparison A_FM%MFM%MP(2) is the FM exponent and A_FM%MFM%MP(3) is the FM
!             first digit of A_FM.  So this is a quick way to check that the two endpoints
!             of interval X agree about the leading digit of BASE**J.

         IF (A_FM%MFM%MP(2) /= B_FM%MFM%MP(2) .OR. A_FM%MFM%MP(3) /= B_FM%MFM%MP(3)) THEN
             WRITE (22,"(//A,I6)") ' In example 11 the two endpoints do not agree about the' //  &
                                   ' leading digit.  N_PRECISION was ', N_PRECISION
             WRITE (22,"(//A//)")  ' Try again with N_PRECISION set 10 higher'
             STOP
         ENDIF

!             Extract the leading decimal digit from BASE**J.
!             FM is storing the numbers in a power-of-ten base, so the leading FM digit
!             may have several base 10 digits.  Divide by 10 until the base 10 leading
!             digit remains.

         K = A_FM%MFM%MP(3)
         DO WHILE (K > 0)
            I = K/10
            IF (I == 0) THEN
                DIGIT_COUNT(K) = DIGIT_COUNT(K) + 1
                EXIT
            ELSE
                K = I
            ENDIF
         ENDDO

!             5^(1,000,000,000) could overflow if FM is being run on a machine using 32-bit
!             integers.  Since we only care about the leading digits of the powers, normalize
!             the FM exponent of X if it gets too big.

         IF (A_FM%MFM%MP(2) > 5.0D+7) THEN
             X%LEFT%MP(2)  = 0
             X%RIGHT%MP(2) = 0
         ENDIF
      ENDDO

      WRITE (22,"(//I2,A,9I10//)") BASE, '^n counts = ', DIGIT_COUNT

      WRITE (22,*) ' '
      WRITE (22,*) ' '

      CLOSE(22)
      STOP

      END PROGRAM TEST

      FUNCTION F(NF, X)     RESULT (RETURN_VALUE)

      USE FMZM
      USE FM_INTERVAL_ARITHMETIC
      IMPLICIT NONE
      INTEGER :: NF
      TYPE (FM_INTERVAL) :: RETURN_VALUE, X

      IF (NF == 1) THEN
          RETURN_VALUE = SIN(X) / X
      ENDIF

      END FUNCTION F

      SUBROUTINE GAUSS_9(NF, A, B, N, RESULT)

!  Sample subroutine usage for FM.

!  Integrate F(NF, X) from A to B using N subintervals, and return the answer in RESULT.

!  This does numerical integration using a 9-point Gauss quadrature rule.
!  It is not a very good way to do high-precision integration, but it is a short routine
!  and can often get 50 digits if f(x) is well-behaved and the interval of integration
!  is not too big.

      USE FMVALS
      USE FMZM
      USE FM_INTERVAL_ARITHMETIC
      IMPLICIT NONE
      TYPE (FM_INTERVAL) :: A, B, RESULT
      TYPE (FM_INTERVAL), SAVE :: AJ, H2, XJ, XI(9), WI(9)
      TYPE (FM_INTERVAL), EXTERNAL :: F
      TYPE (FM), SAVE :: WIDTH_FM
      INTEGER :: NF, N, J, K
      INTEGER, SAVE :: COEFF_BASE = 0, COEFF_PRECISION = 0
      INTENT (IN) :: N, A, B
      INTENT (INOUT) :: RESULT

      IF (COEFF_BASE /= MBASE .OR. COEFF_PRECISION < NDIG) THEN
          COEFF_BASE = MBASE
          COEFF_PRECISION = NDIG
          XI(9) = TO_FM(' 0.968160239507626089835576202903672870049404800491925329550023 ')
          XI(1) = -XI(9)
          XI(8) = TO_FM(' 0.836031107326635794299429788069734876544106718124675996104372 ')
          XI(2) = -XI(8)
          XI(7) = TO_FM(' 0.613371432700590397308702039341474184785720604940564692872813 ')
          XI(3) = -XI(7)
          XI(6) = TO_FM(' 0.324253423403808929038538014643336608571956260736973088827047 ')
          XI(4) = -XI(6)
          XI(5) = 0

          WI(9) = TO_FM(' 0.081274388361574411971892158110523650675661720782410750711108 ')
          WI(1) = WI(9)
          WI(8) = TO_FM(' 0.180648160694857404058472031242912809514337821732040484498336 ')
          WI(2) = WI(8)
          WI(7) = TO_FM(' 0.260610696402935462318742869418632849771840204437299951939997 ')
          WI(3) = WI(7)
          WI(6) = TO_FM(' 0.312347077040002840068630406584443665598754861261904645554011 ')
          WI(4) = WI(6)
          WI(5) = TO_FM(' 32768 ') / 99225
      ENDIF

      RESULT = 0
      H2    = ( B - A ) / ( 2 * N )
      DO J = 1, N
         AJ = A + (J-1) * 2 * H2
         DO K = 1, 9
            XJ = AJ + H2 + H2 * XI(K)
            RESULT = RESULT + F( NF, XJ ) * WI(K)
         ENDDO
         IF (MOD(J,N/1000) == 0) THEN
             WIDTH_FM = MAX( RIGHT_ENDPOINT(RESULT)-LEFT_ENDPOINT(RESULT) ,  &
                             EPSILON(LEFT_ENDPOINT(RESULT)) )
             WRITE (31,"(A,I7,A,F8.3,A)") '{', J, ',', TO_DP(LOG(WIDTH_FM)) / LOG(10.0D0), '},'
         ENDIF
      ENDDO

      RESULT = RESULT * H2

      END SUBROUTINE GAUSS_9

   MODULE RK_FUNCT

!  For a function to return an array as its function value, there must be an explicit interface.

!  F is the generic name of the function, F_RK is the specific version for 1-dimensional arrays.

      INTERFACE F
         MODULE PROCEDURE F_RK
      END INTERFACE

      CONTAINS

      FUNCTION F_RK( X, V, K_FUNCTION )     RESULT (RETURN_VALUE)
      USE FMZM
      USE FM_INTERVAL_ARITHMETIC

      IMPLICIT NONE

      INTEGER :: K_FUNCTION
      TYPE (FM_INTERVAL) :: X, V(5), RETURN_VALUE(5)

      RETURN_VALUE = 0

      IF (K_FUNCTION == 1) THEN

!             Function 1.   y'' = -y' / 10  -  2 * y / (x+2),
!                           y(0) = 0,   y'(0) = 1

!                           v' = {  y' ,  y'' } = {  u  ,  -u / 10  -  2 y / (x+2)  } = F(x,v)

          RETURN_VALUE(1) = V(2)
          RETURN_VALUE(2) = -V(2) / 10 - 2 * V(1) / ( X + 2 )

      ELSE IF (K_FUNCTION == 2) THEN

!             Function 2.   y'' = -y' / 10  -  200 * y / (x+2),
!                           y(0) = 0,   y'(0) = 1

!                           v' = {  y' ,  y'' } = {  u  ,  -u / 10  -  2 y / (x+2)  } = F(x,v)

          RETURN_VALUE(1) = V(2)
          RETURN_VALUE(2) = -V(2) / 10 - 200 * V(1) / ( X + 2 )

      ELSE
          RETURN_VALUE(1) = X*V(1)
      ENDIF

      END FUNCTION F_RK

   END MODULE RK_FUNCT

      SUBROUTINE RK4(N_ORDER, A, B, N_STEPS, V, K_FUNCTION, KPRT, KW)
      USE FMZM
      USE FM_INTERVAL_ARITHMETIC
      USE RK_FUNCT

!   N_ORDER is the order of the DE
!   A is the initial x-value
!   B is the final x-value
!   N_STEPS is the number of steps done.
!   V contains the initial values at x = a on input, and is returned with the solution
!     values at x = b.
!   K_FUNCTION is the function number for the RHS.
!   KPRT > 0 causes the solution to be printed on unit KW after each KPRT steps.

      IMPLICIT NONE

      INTEGER :: J, K, K_FUNCTION, KPRT, KW, N_ORDER, N_STEPS
      TYPE (FM_INTERVAL) :: A, B, H, X, V(5), K1(5), K2(5), K3(5), K4(5)
      TYPE (FM) :: ERROR_FM, WIDTH_FM

      SAVE :: H, X, K1, K2, K3, K4

      X = A
      H = (B-A)/N_STEPS
      IF (N_ORDER < 5) V(N_ORDER+1:5) = 0

      DO J = 1, N_STEPS
         K1 = H * F( X     , V      , K_FUNCTION )
         K2 = H * F( X+H/2 , V+K1/2 , K_FUNCTION )
         K3 = H * F( X+H/2 , V+K2/2 , K_FUNCTION )
         K4 = H * F( X+H   , V+K3   , K_FUNCTION )
         X = A + J*H
         V = V + ( K1 + 2*K2 + 2*K3 + K4 ) / 6

         IF (KPRT > 0) THEN
             IF (MOD(J,KPRT) == 0) THEN
                 ERROR_FM = ABS( (RIGHT_ENDPOINT(V(1))-LEFT_ENDPOINT(V(1))) / RIGHT_ENDPOINT(V(1)) )
                 K = -NINT(LOG10(ERROR_FM))
                 WRITE (KW,"(A,F15.10,A,2F20.15,A,I3,A)") '  X = ',TO_DP(X),'   V = ', &
                       TO_DP(V(1:N_ORDER)),'     Endpoints of V(1) agree to ', K, ' digits.'
             ENDIF
         ENDIF

         IF (MOD(J,N_STEPS/1000) == 1) THEN
             WIDTH_FM = MAX( RIGHT_ENDPOINT(V(1))-LEFT_ENDPOINT(V(1)) ,  &
                             EPSILON(LEFT_ENDPOINT(V(1))) )
             IF (K_FUNCTION == 1) THEN
                 WRITE (31,"(A,I7,A,F8.3,A)") '{', J, ',', TO_DP(LOG(WIDTH_FM)) / LOG(10.0D0), '},'
             ELSE
                 WRITE (31,"(A,I7,A,F8.3,A)") '{', J, ',', TO_DP(LOG(WIDTH_FM)) / LOG(10.0D0), '},'
             ENDIF
         ENDIF
      ENDDO

      END SUBROUTINE RK4

      SUBROUTINE FM_INTERVAL_FACTOR_LU(A,N,DET,KSWAP)
      USE FMZM
      USE FM_INTERVAL_ARITHMETIC
      IMPLICIT NONE

!  Gauss elimination to factor the NxN matrix A (LU decomposition).

!  The time is proportional to  N**3.

!  Once this factorization has been done, a linear system  A x = b
!  with the same coefficient matrix A and Nx1 vector b can be solved
!  for x using routine FM_INTERVAL_SOLVE_LU in time proportional to  N**2.

!  DET is returned as the determinant of A.
!      Nonzero DET means a solution can be found.
!      DET = 0 is returned if the system is singular.

!  KSWAP is a list of row interchanges made by the partial pivoting strategy during the
!        elimination phase.

!  After returning, the values in matrix A have been replaced by the multipliers
!  used during elimination.  This is equivalent to factoring the A matrix into
!  a lower triangular matrix L times an upper triangular matrix U.

      INTEGER :: N
      INTEGER :: JCOL, JDIAG, JMAX, JROW, KSWAP(N)
      TYPE (FM_INTERVAL) :: A(N,N), DET
      TYPE (FM_INTERVAL), SAVE :: AMAX, AMULT, TEMP

      DET = 1
      KSWAP(1:N) = 1
      IF (N <= 0) THEN
          DET = 0
          RETURN
      ENDIF
      IF (N == 1) THEN
          KSWAP(1) = 1
          DET = A(1,1)
          RETURN
      ENDIF

!             Do the elimination phase.
!             JDIAG is the current diagonal element below which the elimination proceeds.

      DO JDIAG = 1, N-1

!             Pivot to put the element with the largest absolute value on the diagonal.

         AMAX = ABS(A(JDIAG,JDIAG))
         JMAX = JDIAG
         DO JROW = JDIAG+1, N
            IF (ABS(A(JROW,JDIAG)) > AMAX) THEN
                AMAX = ABS(A(JROW,JDIAG))
                JMAX = JROW
            ENDIF
         ENDDO

!             If AMAX is zero here then the system is singular.

         IF (AMAX == 0.0) THEN
             DET = 0
             RETURN
         ENDIF

!             Swap rows JDIAG and JMAX unless they are the same row.

         KSWAP(JDIAG) = JMAX
         IF (JMAX /= JDIAG) THEN
             DET = -DET
             DO JCOL = JDIAG, N
                TEMP = A(JDIAG,JCOL)
                A(JDIAG,JCOL) = A(JMAX,JCOL)
                A(JMAX,JCOL) = TEMP
             ENDDO
         ENDIF
         DET = DET * A(JDIAG,JDIAG)

!             For JROW = JDIAG+1, ..., N, eliminate A(JROW,JDIAG) by replacing row JROW by
!                 row JROW - A(JROW,JDIAG) * row JDIAG / A(JDIAG,JDIAG)

         DO JROW = JDIAG+1, N
            IF (A(JROW,JDIAG) == 0) CYCLE
            AMULT = A(JROW,JDIAG)/A(JDIAG,JDIAG)

!             Save the multiplier for use later by FM_INTERVAL_SOLVE_LU.

            A(JROW,JDIAG) = AMULT
            A(JROW,JDIAG+1:N) = A(JROW,JDIAG+1:N) - AMULT*A(JDIAG,JDIAG+1:N)
         ENDDO
      ENDDO
      DET = DET * A(N,N)

      END SUBROUTINE FM_INTERVAL_FACTOR_LU

      SUBROUTINE FM_INTERVAL_SOLVE_LU(A,N,B,X,KSWAP)
      USE FMZM
      USE FM_INTERVAL_ARITHMETIC
      IMPLICIT NONE

!  Solve a linear system  A x = b.
!  A is the NxN coefficient matrix, after having been factored by FM_INTERVAL_FACTOR_LU.
!  B is the Nx1 right-hand-side vector.
!  X is returned with the solution of the linear system.
!  KSWAP is a list of row interchanges made by the partial pivoting strategy during the
!        elimination phase in FM_INTERVAL_FACTOR_LU.
!  Time for this call is proportional to  N**2.

      INTEGER :: N, KSWAP(N)
      TYPE (FM_INTERVAL) :: A(N,N), B(N), X(N)
      TYPE (FM_INTERVAL), SAVE :: TEMP
      INTEGER :: JDIAG, JMAX

      IF (N <= 0) THEN
          RETURN
      ENDIF
      IF (N == 1) THEN
          X(1) = B(1) / A(1,1)
          RETURN
      ENDIF
      X(1:N) = B(1:N)

!             Do the elimination phase operations only on X.
!             JDIAG is the current diagonal element below which the elimination proceeds.

      DO JDIAG = 1, N-1

!             Pivot to put the element with the largest absolute value on the diagonal.

         JMAX = KSWAP(JDIAG)

!             Swap rows JDIAG and JMAX unless they are the same row.

         IF (JMAX /= JDIAG) THEN
             TEMP = X(JDIAG)
             X(JDIAG) = X(JMAX)
             X(JMAX) = TEMP
         ENDIF

!             For JROW = JDIAG+1, ..., N, eliminate A(JROW,JDIAG) by replacing row JROW by
!                 row JROW - A(JROW,JDIAG) * row JDIAG / A(JDIAG,JDIAG)
!             After factoring, A(JROW,JDIAG) is the original A(JROW,JDIAG) / A(JDIAG,JDIAG).

         X(JDIAG+1:N) = X(JDIAG+1:N) - A(JDIAG+1:N,JDIAG)*X(JDIAG)
      ENDDO

!             Do the back substitution.

      DO JDIAG = N, 1, -1

!             Divide row JDIAG by the diagonal element.

         X(JDIAG) = X(JDIAG) / A(JDIAG,JDIAG)

!             Zero above the diagonal in column JDIAG by replacing row JROW by
!                 row JROW - A(JROW,JDIAG) * row JDIAG
!             For JROW = 1, ..., JDIAG-1.

         IF (JDIAG == 1) EXIT
         X(1:JDIAG-1) = X(1:JDIAG-1) - A(1:JDIAG-1,JDIAG)*X(JDIAG)
      ENDDO

      END SUBROUTINE FM_INTERVAL_SOLVE_LU


program tarefac
    implicit real*8 (a-h,o-z)
    ! variaveis auxiliaris para indicar parada de cada metodo
    logical flag_dir, flag_new, flag_sec

    erro = 10d-6   ! erro
    nmax = 100     ! iteração maxima
    h_sec = 0.005  ! valor de h para o metodo da secante
    h_dir = 3      ! valor de h para definir intervalo a b do metodo direto
    n = 0          ! valor da iteração

    ! variaveis de desvio
    desv_dir = 2*erro
    desv_new = 2*erro
    desv_sec = 2*erro

    ! flags
    flag_dir = .true.
    flag_new = .true.
    flag_sec = .true.

    ! recebe o valor para iniciar
    write(*,*) 'Digite um valor para iniciar a busca:'
    read(*,*) a

    ! define o valor de b do intervalo
    b = a + h_dir

    ! loop para encontrar o melhor intervalo
    do while ( f(a)*f(b) .gt. 0 )
        a = b
	b = b + h_dir
    end do

    ! escreve o valor de que irá iniciar todos os metodos
    write(*,'(A,1F0.11)') 'Valor inicial encontrado = ', a

    ! definindo valor inicial para newton e secante
    x0_new = a
    x0_sec = a

    ! loop que itera cada metodo, e para quando todas as flags indicam false ou atingiu o nmax
    do while ( (n <= nmax) .and. (flag_dir .or. flag_new .or. flag_sec) )

	! metodo direto
	! verifica se o desvio já atingiu o erro
	if ( desv_dir .gt. erro ) then
	    ! valor medio de ab
            x_dir = (a+b)/2
            ! verifica se o produto e redefine a ou b
            if ( f(x_dir)*f(a) .gt. 0 ) then
                a = x_dir
            else
                b = x_dir
            end if
            ! atualiza o valor do desvio
            desv_dir = abs(f(a)-f(b))
        else
            flag_dir = .false.
        end if

	! metodo de newton
	! verifica se o desvio já atingiu o erro
        if ( desv_new .gt. erro ) then
            x_new = x0_new - f(x0_new)/df(x0_new)
	    ! atualiza o valor do desvio
            desv_new = abs(f(x_new) - f(x0_new))
	    ! redefine x0
            x0_new = x_new
        else
            flag_new = .false.
        end if

	! metodo da secante
        ! verifica se o desvio já atingiu o erro
        if ( desv_sec .gt. erro ) then
	    ! derivada numerica de f
            df_sec = ( f(x0_sec + h_sec) - f(x0_sec) ) / h_sec
            x_sec = x0_sec - f(x0_sec)/df_sec
	    ! atualiza o desvio
            desv_sec = abs(f(x_sec) - f(x0_sec))
	    ! redefine x0
            x0_sec = x_sec
        else
            flag_sec = .false.
        end if

	! escreve na tela o numero da iteração e o ultimo x encontrado
        write(*,*) n, x_dir, x_new, x_sec
	! soma 1 em n
        n = n + 1
    end do

contains ! funções utilizadas f(x) e a derivada de f(x)

    function f(x)
        f = x**3 -21*x -20
        return
    end function

    function df(x)
        df = 3*x**2 -21
        return
    end function

end program tarefac


subroutine lsf_gauss(x,n,fwhm,lsf)

!reconstructs a 1D Gaussian lsf

use share, only: dp, pi

implicit none

!input/output
real(dp), intent(in) :: x(n)    ! pixel location array
integer, intent(in)  :: n       ! number of data points
real(dp), intent(in) :: fwhm    ! fwhm of the lsf
real(dp), intent(out):: lsf(n)  ! lsf profile

!locals
real(dp)     :: sigma_to_fwhm

sigma_to_fwhm = 2.0_dp*sqrt(-2.0_dp*log(0.5_dp))

lsf(1:n)=1.0_dp/sqrt(2.0_dp*pi)/fwhm*sigma_to_fwhm *  &
		exp(-(x(1:n)/fwhm*sigma_to_fwhm)**2/2.0_dp)

lsf(1:n)=lsf(1:n)/sum(lsf(1:n))

end subroutine lsf_gauss


PROGRAM diff
IMPLICIT NONE
INTEGER, PARAMETER :: SGL = SELECTED_REAL_KIND(p=6,r=37)
INTEGER, PARAMETER :: DBL = SELECTED_REAL_KIND(p=13)
REAL(KIND=DBL) :: ans, d_ans, d_error, d_fx, d_fxdx, d_dx, d_x = 0.15_DBL
INTEGER :: i
REAL(KIND=SGL) :: s_ans, s_error, s_fx, s_fxdx, s_dx, s_x = 0.15_SGL
WRITE(*, 1)
1 FORMAT ('        DX    TRUE ANS      SP ANS                DP ANS', &
          '   SP ERR   DP ERR')
ans = - (1.0_DBL / d_x**2)
step_size: DO i = 1, 10
  s_dx = 1.0 / 10.0**i
  d_dx = 1.0_DBL / 10.0_DBL**i
  s_fxdx = 1. / (s_x + s_dx)
  s_fx = 1. / s_x
  s_ans = (s_fxdx - s_fx) / s_dx
  s_error = (s_ans - REAL(ans)) / REAL(ans) * 100.
  d_fxdx = 1.0_DBL / (d_x + d_dx)
  d_fx = 1.0_DBL / d_x
  d_ans = (d_fxdx - d_fx) / d_dx
  d_error = (d_ans - ans) / ans * 100.
  WRITE(*, 100) d_dx, ans, s_ans, d_ans, s_error, d_error
  100 FORMAT (ES10.3, F12.7, F12.7, ES22.14, F9.3, F9.3)
END DO step_size

END PROGRAM diff


program test_constants
use types, only: dp
use constants, only: pi, e_, i_
use utils, only: assert
implicit none

! Euler's identity:
call assert(abs(e_**(pi*i_) + 1) < 1e-15_dp)

end program


subroutine set_true_solution(x, y, t, components)

    implicit none

    double precision, intent(in) :: x, y, t
    double precision, dimension(2), intent(out) :: components

    double precision :: t0, tau, rho
    parameter(t0 = 1.d0)

    tau = t + t0
    rho = sqrt(x**2 + y**2) / tau**.25d0

    components(1) = 2.d0 * rho**2
    components(2) = -1.d0 / (8.d0 * tau**.5d0) * log(rho)

end subroutine set_true_solution


      real*8 function norma2(n,x)
      implicit none
      integer n,i
      real*8  x(n)

      norma2=0.d0
      do i=1,n
          norma2=norma2+ x(i)*x(i)
      end do
      norma2=dsqrt(norma2)

      return
      end


subroutine djpi2(dj, lmax)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This subroutine computes
!	  j
!	d     (pi/2)
!	  m N
!
!	for all posible values of m (>=0) and N for 0<l<lmax.
!	The output array corresponds to dj(N,m,j). (I'm not positive
!	about the N and m ordering).
!
!	Note that this algorithm is easy to modify to work on a
!	single l (just need a loop to compute f1) since there are
!	no l recursions involved.
!
!	Calling Parameters
!		IN
!			lmax	Maximum spherical harmonic degree to be computed.
!		OUT
!			dj	Rotation matrix with dimensions (lmax+1, lmax+1, lmax+1).
!
!	Dependencies:	None
!
!	History
!
!		1. Based on routine from Guy Masters (July 16, 1993)
!		2. Modified by Mark Simons (July 19, 1993)
!		3. Turned into readable f95 code by Mark Wieczorek (August, 2003).
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	integer, intent(in) ::	lmax
	real*8, intent(out) ::	dj(:,:,:)
	integer ::		i, l, n, lp1, j, m, isn, np
	real*8 ::		f((lmax+1)*8), f1, f2, g1, g2, en2, fl2p1

	if (size(dj(:,1,1)) < lmax+1 .or. size(dj(1,:,1)) < lmax + 1 .or. size(dj(1,1,:)) < lmax +1) then
		print*, "Error --- djpi2"
		print*, "DJ must be dimensioned (LMAX+1, LMAX+1, LMAX+1) where LMAX is ", lmax
		print*, "Input array is dimensioned as ", size(dj(:,1,1)), size(dj(1,:,1)), size(dj(1,1,:))
		stop
	endif

	dj = 0.0d0

	dj(1,1,1) = 1.d0
	dj(1,1,2) = 0.d0
	dj(1,2,2) = -1.0d0/sqrt(2.0d0)
	dj(2,1,2) = -dj(1,2,2)
	dj(2,2,2) = 0.5d0
	f1        = 0.5d0

	do l = 2, lmax

		lp1   = l+1
		fl2p1 = l+lp1

		do i = 1, l
			f(i) = dsqrt(i*(fl2p1-i))
        	enddo

        	f1 = f1*(l+l-1.0d0)/(l+l)

		! Do N = 0 terms

		dj(lp1,1,lp1) = -dsqrt(f1)
		dj(l,1,lp1)   = 0.0d0

		do i = 2, l
			j = lp1-i
			dj(j,1,lp1) = -f(i-1)*dj(j+2,1,lp1)/f(i)
		enddo

		! Do positive N terms (bottom triangle)

		f2 = f1
		g1 = l
		g2 = lp1

		do n = 1, l
			np = n+1
			en2 = n+n
			g1 = g1 + 1.0d0
			g2 = g2 - 1.0d0
			f2 = f2*g2/g1
			dj(lp1,np,lp1) = -dsqrt(f2)
			dj(l,np,lp1) = dj(lp1,np,lp1)*en2/f(1)

			do i = 2, l-n
				j = lp1-i
				dj(j,np,lp1) = ( en2*dj(j+1,np,lp1) &
					- f(i-1)*dj(j+2,np,lp1) ) / f(i)
			enddo

		enddo

		! Fill upper triangle and fix signs

		do j = 1, l
			do m = j,l
				dj(j,m+1,lp1) = dj(m+1,j,lp1)
			enddo
		enddo

		isn = 1 + mod(l,2)

		do np = 1, lp1
			do i = isn, lp1, 2
				dj(i,np,lp1) = -dj(i,np,lp1)
			enddo
		enddo

	enddo

end subroutine djpi2


subroutine vecnor(v,n,vnor,inor)

!-----------------------------------------------------------------------
!
! Compute the L1, L2 and L-inf norms of a vector V of length N
!
!-----------------------------------------------------------------------
  use      typre
  implicit none
  integer(ip), intent(in)  :: n,inor
  real(rp),    intent(in)  :: v(n)
  real(rp),    intent(out) :: vnor
  integer(ip)              :: i

  vnor=0.0_rp
  if(inor==0.or.inor==3) then
     do i=1,n
        if(abs(v(i))>vnor) vnor=abs(v(i))
     end do
  else if(inor==1) then
     do i=1,n
        vnor=vnor+abs(v(i))
     end do
  else if(inor==2) then
     do i=1,n
        vnor=vnor+v(i)*v(i)
     end do
     vnor=sqrt(vnor)
  end if

end subroutine vecnor

subroutine vecnorALLMPI(v,ndime,n,vnor,inor,MPIComm,MPIrank,MPIroot,MPIsize)

!-----------------------------------------------------------------------
!
! Compute the L1, L2 and L-inf norms of a vector V of length N
!
!-----------------------------------------------------------------------
!Returns correct result only for rank 0!!
  use      typre
  use MPI
  implicit none
  integer(ip), intent(in)  :: n,inor,ndime
  real(rp),    intent(in)  :: v(ndime,n)
  real(rp),    intent(out) :: vnor
  integer(ip) :: i
  integer(ip) :: MPIComm,MPIrank,MPIroot,MPIsize
  integer(ip) :: ierr,idime
  real(rp)    :: vnor0,va

  vnor0=0.0_rp
  if(inor==0.or.inor==3) then
     do i = 1,n
        do idime = 1,ndime
         va = v(idime,i)
         if(abs(va)>vnor0) vnor0=abs(va)
        enddo
     end do

     call  MPI_ALLREDUCE( vnor0, vnor, 1, MPI_REAL8, MPI_MAX, MPIroot,MPIcomm, ierr )

  else if(inor==1) then
     do i = 1,n
        do idime = 1,ndime
         va = v(idime,i)
         vnor0=vnor0+abs(va)
        enddo
     end do

     call  MPI_ALLREDUCE( vnor0, vnor, 1, MPI_REAL8, MPI_SUM, MPIroot,MPIcomm, ierr )

  else if(inor==2) then

     do i = 1,n
        do idime = 1,ndime
         va = v(idime,i)
         vnor0 = vnor0 + va*va
        enddo
     end do

     call  MPI_ALLREDUCE( vnor0, vnor, 1, MPI_REAL8, MPI_SUM, MPIroot,MPIcomm, ierr )

     vnor=sqrt(vnor)
  end if

end subroutine vecnorALLMPI

subroutine vecnorMPI(v,n,vnor,inor,MPIComm,MPIrank,MPIroot,MPIsize)

!-----------------------------------------------------------------------
!
! Compute the L1, L2 and L-inf norms of a vector V of length N
!
!-----------------------------------------------------------------------
!Returns correct result only for rank 0!!
  use      typre
  use MPI
  implicit none
  integer(ip), intent(in)  :: n,inor
  real(rp),    intent(in)  :: v(n)
  real(rp),    intent(out) :: vnor

  integer(ip)              :: i
  integer(ip) :: MPIComm,MPIrank,MPIroot,MPIsize
  integer(ip) :: ierr
  real(rp) :: vnor0

  vnor0=0.0_rp
  if(inor==0.or.inor==3) then
     do i=1,n
        if(abs(v(i))>vnor0) vnor0=abs(v(i))
     end do

     call  MPI_REDUCE( vnor0, vnor, 1, MPI_REAL8, MPI_MAX, MPIroot,MPIcomm, ierr )
  else if(inor==1) then
     do i=1,n
        vnor0=vnor0+abs(v(i))
     end do
     call  MPI_REDUCE( vnor0, vnor, 1, MPI_REAL8, MPI_SUM, MPIroot,MPIcomm, ierr )
  else if(inor==2) then
     do i=1,n
        vnor0=vnor0+v(i)*v(i)
     end do
     call  MPI_REDUCE( vnor0, vnor, 1, MPI_REAL8, MPI_SUM, MPIroot,MPIcomm, ierr )
     vnor=sqrt(vnor)
  end if

end subroutine vecnorMPI

subroutine vecnorGenericMPI(v,n,ndime,vnor,inor,MPIcomm,MPIrank,MPIroot,MPIsize)

!-----------------------------------------------------------------------
!
! Compute the L1, L2 and L-inf norms of a vector V of length N
!
!-----------------------------------------------------------------------
!Returns correct result only for rank 0!!
  use      typre
  use MPI
  implicit none
  integer(ip), intent(in)  :: n,inor,ndime
  real(rp),    intent(in)  :: v(ndime,n)
  real(rp),    intent(out) :: vnor

  integer(ip)              :: i,idime
  integer(ip) :: MPIcomm,MPIrank,MPIroot,MPIsize
  integer(ip) :: ierr
  real(rp) :: vnor0,val

  val  =0.0_rp
  vnor0=0.0_rp
  if(inor==0.or.inor==3) then

      do i=1,n
          do idime = 1,ndime
              if(abs(v(idime,i))>vnor0) vnor0=abs(v(idime,i))
          enddo
      end do

     call  MPI_REDUCE( vnor0, vnor, 1, MPI_REAL8, MPI_MAX, MPIroot,MPIcomm, ierr )

  else if(inor==1) then

     do i=1,n
         do idime = 1,ndime
             vnor0=vnor0+abs(v(idime,i))
         enddo
     end do
     call  MPI_REDUCE( vnor0, vnor, 1, MPI_REAL8, MPI_SUM, MPIroot,MPIcomm, ierr )

  else if(inor==2) then

     do i = 1,n
        do idime = 1,ndime
         val = v(idime,i)
         vnor0 = vnor0 + val*val
        enddo
     end do

     call  MPI_REDUCE( vnor0, vnor, 1, MPI_REAL8, MPI_SUM, MPIroot,MPIcomm, ierr )
     vnor=sqrt(vnor)
  end if

end subroutine vecnorGenericMPI

subroutine matNormF(ndime,matrix,matnor)
   !-----------------------------------------------------------------------
   !
   ! This routine computes the norm of a matrix
   !    norm = [sum_j sum_i |A_ij|^2]^0.5
   !
   !-----------------------------------------------------------------------
   use      typre
   implicit none
   integer(ip), intent(in)    :: ndime
   real(rp),    intent(in)    :: matrix(ndime,ndime)
   real(rp),    intent(out)   :: matnor

   real(rp)                   :: aux
   integer(ip)                :: idime,jdime

   aux = 0.0_rp
   do idime = 1,ndime
      do jdime = 1,ndime
         aux = aux + (matrix(idime,jdime)*matrix(idime,jdime))
      enddo
   enddo

   matnor = sqrt(aux)

end subroutine matNormF


MODULE SortMod

  ! mbp 1/2015 incorporating subroutines from decades past

  IMPLICIT NONE
  INTEGER, PRIVATE :: ILeft, IMiddle, IRight, I

  INTERFACE Sort
     MODULE PROCEDURE Sort_sngl, Sort_dble, Sort_cmplx
  END INTERFACE Sort

CONTAINS

  SUBROUTINE Sort_sngl( x, N )

    ! Does an insertion sort on a vector of real numbers

    ! At the Ith step, the first I-1 positions contain a sorted
    ! vector.  We shall insert the Ith value into its place in that
    ! vector shifting up to produce a new vector of length I.

    INTEGER, INTENT( IN ) :: N
    REAL    :: x( * ), xTemp

    IF ( N == 1 ) RETURN

    DO I = 2, N

       xTemp = x( I )

       IF ( xTemp < x( 1 ) ) THEN
          x( 2 : I ) = x( 1 : I - 1 )
          x( 1 )     = xTemp  ! goes in the first position
       ELSE IF ( xTemp < x( I - 1 ) ) THEN ! Binary search for its place

          IRight = I - 1
          ILeft  = 1

          DO WHILE ( IRight > ILeft + 1 )
             IMiddle = ( ILeft + IRight ) / 2
             IF ( xTemp < x( IMiddle ) ) THEN
                IRight = IMiddle
             ELSE
                ILeft  = IMiddle
             ENDIF
          END DO

          ! Shift and insert
          x( IRight + 1 : I ) = x( IRight : I - 1 )
          x( IRight ) = xTemp

       ENDIF

    END DO

  END SUBROUTINE Sort_sngl

  ! ________________________________________________________________________

  SUBROUTINE Sort_dble( x, N )

    ! Does an insertion sort on a vector of real numbers

    ! At the Ith step, the first I-1 positions contain a sorted
    ! vector.  We shall insert the Ith value into its place in that
    ! vector shifting up to produce a new vector of length I.

    INTEGER, INTENT( IN ) :: N
    REAL (KIND=8) :: x( * ), xTemp

    IF ( N == 1 ) RETURN

    DO I = 2, N

       xTemp = x( I )

       IF ( xTemp < x( 1 ) ) THEN
          x( 2 : I ) = x( 1 : I - 1 )
          x( 1 )     = xTemp  ! goes in the first position
       ELSE IF ( xTemp < x( I - 1 ) ) THEN ! Binary search for its place

          IRight = I - 1
          ILeft  = 1

          DO WHILE ( IRight > ILeft + 1 )
             IMiddle = ( ILeft + IRight ) / 2
             IF ( xTemp < x( IMiddle ) ) THEN
                IRight = IMiddle
             ELSE
                ILeft  = IMiddle
             ENDIF
          END DO

          ! Shift and insert
          x( IRight + 1 : I ) = x( IRight : I - 1 )
          x( IRight ) = xTemp

       ENDIF

    END DO

  END SUBROUTINE Sort_dble

  ! ________________________________________________________________________

  SUBROUTINE Sort_cmplx( x, N )

    ! Does an insertion sort of the complex vector x in order of decreasing real part

    ! At the Ith step, the first I-1 positions contain a sorted vector.
    ! We shall insert the Ith value into its place in that
    ! vector, shifting up to produce a new vector of length I.

    INTEGER, INTENT( IN ) :: N
    COMPLEX (KIND=8)      :: x( N ), xTemp

    IF ( N == 1 ) RETURN

    DO I = 2, N

       xTemp = x( I )

       IF ( REAL( xTemp ) > REAL( x( 1 ) ) ) THEN
          x( 2 : I ) = x( 1 : I - 1 )
          x( 1 )     = xTemp  ! goes in the first position
       ELSE IF ( REAL( xTemp ) > REAL( x( I - 1 ) ) ) THEN

          ! Binary search for its place

          IRight = I - 1
          ILeft  = 1

          DO WHILE ( IRight > ILeft + 1 )
             IMiddle = ( ILeft + IRight ) / 2

             IF ( REAL( xTemp ) > REAL( x( IMiddle ) ) ) THEN
                IRight = IMiddle
             ELSE
                ILeft  = IMiddle
             END IF
          END DO

          x( IRight + 1 : I ) = x( IRight : I - 1 )
          x( IRight ) = xTemp

       END IF

    END DO

  END SUBROUTINE Sort_cmplx

END MODULE SortMod


     program main
     use mpi
     double precision  PI25DT
     parameter        (PI25DT = 3.141592653589793238462643d0)
     double precision  mypi, pi, h, sum, x, f, a
     integer n, myid, numprocs, i, ierr
!                                function to integrate
     f(a) = 4.d0 / (1.d0 + a*a)

     call MPI_INIT(ierr)
     call MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
     call MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)

     do
        if (myid .eq. 0) then
           print *, 'Enter the number of intervals: (0 quits) '
           read(*,*) n
        endif
!                                broadcast n
        call MPI_BCAST(n, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr)
!                                check for quit signal
        if (n .le. 0) exit
!                                calculate the interval size
        h = 1.0d0/n
        sum  = 0.0d0
        do i = myid+1, n, numprocs
           x = h * (dble(i) - 0.5d0)
           sum = sum + f(x)
        enddo
        mypi = h * sum
!                                collect all the partial sums
        call MPI_REDUCE(mypi, pi, 1, MPI_DOUBLE_PRECISION, &
                        MPI_SUM, 0, MPI_COMM_WORLD, ierr)
!                                node 0 prints the answer.
        if (myid .eq. 0) then
           print *, 'pi is ', pi, ' Error is', abs(pi - PI25DT)
        endif
     enddo
     call MPI_FINALIZE(ierr)
     end


program compute_pi
implicit none

	integer me,nimg,i,n
	real(selected_real_kind(p=33))   pi,psum,x,w
	real(selected_real_kind(p=33))   mypi[*]
	integer(selected_int_kind(r=17)) st,et,rat

	nimg = num_images()
	me   = this_image()

print *, nimg
if(me==1) then
  write(*,*) "please input steps:"
  read(*,*) n
  call system_clock(count=st,count_rate=rat)
end if

w = 1.d0/n
psum = 0.d0
do i= me,n,nimg
  x = w * (i - 0.5d0)
  psum = psum + 4.d0/(1.d0+x*x)
enddo
mypi = w * psum
sync all

if (me==1) then
  pi = mypi
  do i= 2,nimg
    pi = pi + mypi[i]
  enddo
  call system_clock(count=et)
  write(*,*) 'computed time ',(et-st)/real(rat,kind(pi)),'sec'
  write(*,*) 'computed pi = ',pi
  write(*,*) 'real     pi =    3.1415926535897932384626433832795'
endif

end program


program P2
  !  integrate exp(-x) from [-1,+1] by Simpson algorithm
  implicit none
  integer :: i
  integer, dimension(4) :: N
  real*8 :: f_n,f_a,x0=-1.,xf=1.
  real*8, external :: f
  N = (/10,50,100,200/)
  f_a = -exp(x0)+exp(xf)

  do i = 1,4
     call simp(f,x0,xf,N(i),f_n)
     print *,N(i),f_n-f_a,(f_n-f_a)/f_a
  enddo

end program P2

subroutine simp(f,x0,xf,N,sum)
  implicit none
  real*8, intent(in) :: x0,xf
  integer, intent(in) :: N
  real*8, external :: f
  real*8, intent(out) :: sum
  real*8 :: h
  integer :: i
  sum = -f(x0) + f(xf)
  h = (xf-x0)/2./N
  do i=0,2*N,2
     sum = sum + 4.*f(x0+h+i*h) + 2.*f(x0+i*h)
  enddo
  sum = sum*h/3.
end subroutine simp

real*8 function f(x)
  implicit none
  real*8, intent(in) :: x
  f=exp(-x)
end function f


MODULE shape_mod
 USE input_mod,ONLY: runend
 USE esets_mod,ONLY: nnode
 IMPLICIT NONE
 !INTEGER(kind=4),PARAMETER :: shape_nodes=3

CONTAINS
!******************************************************************************
!**         1-Dimension Shape Function Selector                              **
!******************************************************************************
! SUBROUTINE shape_1d_select(xi,N_shape,dN_shape)
!   IMPLICIT NONE
!   !--Dummy arguments
!   REAL(kind=8),INTENT(IN) :: xi
!   REAL(kind=8),ALLOCATABLE,DIMENSION(:),INTENT(OUT) :: N_shape,dN_shape
!   CHARACTER(len=5),INTENT(IN) :: ORDER
!
!   SELECT CASE (nnode)
!   CASE (2)
!     ALLOCATE(N_shape(2),dN_shape(2))
!     CALL linear_shape_1d(xi,N_shape,dN_shape)
!   CASE (3)
!     ALLOCATE(N_shape(3),dN_shape(3))
!     CALL quadratic_shape_1d(xi,N_shape,dN_shape)
!   CASE DEFAULT
!     CALL runend('SHAPE_FUNCTIONS: ORDER not implemented')
!   END SELECT
!******************************************************************************
!**         Linear Shape Functions 1-dimension                               **
!******************************************************************************
 SUBROUTINE linear_shape_1d(xi,N_shape,dN_shape)
   IMPLICIT NONE
   !--Dummy arguments
   REAL(kind=8),INTENT(IN) :: xi
   REAL(kind=8),INTENT(OUT) :: N_shape(2),dN_shape(2)
   !--Local arguments

   !functions
   N_shape(1) = 0.5d0*(1.d0-xi)
   N_shape(2) = 0.5d0*(1.d0+xi)
   !derivatives
   dN_shape(1) = -0.5d0
   dN_shape(2) = 0.5d0

 END SUBROUTINE linear_shape_1d
!******************************************************************************
!**         Quadratic Shape Functions 1-dimension                               **
!******************************************************************************
  SUBROUTINE quadratic_shape_1d(xi,N_shape,dN_shape)
    IMPLICIT NONE
    !--Dummy arguments
    REAL(kind=8),INTENT(IN) :: xi
    REAL(kind=8),INTENT(OUT) :: N_shape(3),dN_shape(3)
    !--Local arguments

    !functions
    N_shape(1) = 0.5d0*xi*(xi-1.d0)
    N_shape(2) = 1.d0-xi**2.d0
    N_shape(3) = 0.5d0*xi*(xi+1.d0)
    !derivatives
    dN_shape(1) = 0.5d0*(2.d0*xi-1.d0)
    dN_shape(2) = 1.d0-2.d0*xi
    dN_shape(3) = 0.5d0*(2.d0*xi+1.d0)

  END SUBROUTINE quadratic_shape_1d

END MODULE shape_mod


program intrinsics_18c
! This program tests all trigonometric intrinsics, both in declarations
! and in executable statements. Single and double precision, complex only.
integer, parameter :: dp = kind(0.d0)

complex, parameter :: &
    s1 = sin((0.5,0.5)), &
    s2 = cos((0.5,0.5)), &
    s3 = tan((0.5,0.5)), &
    s4 = asin((0.5,0.5)), &
    s5 = acos((0.5,0.5)), &
    s6 = atan((0.5,0.5)), &
    s7 = sinh((0.5,0.5)), &
    s8 = cosh((0.5,0.5)), &
    s9 = tanh((0.5,0.5)), &
    s10 = asinh((0.5,0.5)), &
    s11 = acosh((1.5,1.5)), &
    s12 = atanh((0.5,0.5))

complex(dp), parameter :: &
    d1 = sin((0.5_dp,0.5_dp)), &
    d2 = cos((0.5_dp,0.5_dp)), &
    d3 = tan((0.5_dp,0.5_dp)), &
    d4 = asin((0.5_dp,0.5_dp)), &
    d5 = acos((0.5_dp,0.5_dp)), &
    d6 = atan((0.5_dp,0.5_dp)), &
    d7 = sinh((0.5_dp,0.5_dp)), &
    d8 = cosh((0.5_dp,0.5_dp)), &
    d9 = tanh((0.5_dp,0.5_dp)), &
    d10 = asinh((0.5_dp,0.5_dp)), &
    d11 = acosh((1.5_dp,1.5_dp)), &
    d12 = atanh((0.5_dp,0.5_dp))

complex :: x, x2
complex(dp) :: y, y2

x = (0.5,0.5)
y = (0.5_dp,0.5_dp)
x2 = (1.5,1.5)
y2 = (1.5_dp,1.5_dp)

print *, sin((0.5,0.5)), sin((0.5_dp,0.5_dp)), s1, d1, sin(x), sin(y)
print *, cos((0.5,0.5)), cos((0.5_dp,0.5_dp)), s2, d2, cos(x), cos(y)
print *, tan((0.5,0.5)), tan((0.5_dp,0.5_dp)), s3, d3, tan(x), tan(y)

print *, asin((0.5,0.5)), asin((0.5_dp,0.5_dp)), s4, d4, asin(x), asin(y)
print *, acos((0.5,0.5)), acos((0.5_dp,0.5_dp)), s5, d5, acos(x), acos(y)
print *, atan((0.5,0.5)), atan((0.5_dp,0.5_dp)), s6, d6, atan(x), atan(y)

print *, sinh((0.5,0.5)), sinh((0.5_dp,0.5_dp)), s7, d7, sinh(x), sinh(y)
print *, cosh((0.5,0.5)), cosh((0.5_dp,0.5_dp)), s8, d8, cosh(x), cosh(y)
print *, tanh((0.5,0.5)), tanh((0.5_dp,0.5_dp)), s9, d9, tanh(x), tanh(y)

print *, asinh((0.5,0.5)), asinh((0.5_dp,0.5_dp)), s10, d10, asinh(x), asinh(y)
print *, acosh((1.5,1.5)), acosh((1.5_dp,1.5_dp)), s11, d11, acosh(x2), acosh(y2)
print *, atanh((0.5,0.5)), atanh((0.5_dp,0.5_dp)), s12, d12, atanh(x), atanh(y)

end


!> Utility module description goes here!
!! This is a continuation line for the module description.

!> @author J. Kaye
!> @version 0.0

module utils

contains

  !> Evaluate the function \f$ (1-e^{-x})/x \f$ using
  !! a numerically stable method when the exponent is close to unity.
  !! @param[in] x point to evaluate the function
  !! @param[out] val resulting value

  subroutine evalexpfun(x,val)

    implicit none
    real *8 x,val

    integer i
    real *8 one,x1,c

    one = 1.0d0

    if (x>1.0d-1) then

       val = (one-exp(-x))/x

    else

       val = one
       c = one
       x1 = x
       do i=1,10
          c = c*(i+1)
          val = val + ((-1)**i)*x1/c
          x1 = x1*x
       enddo

    endif

  end subroutine evalexpfun

end module utils


subroutine nbody_timestep(position,velocity)
! Adjusts the timestep based on a standard step doubling algorithm
! Takes two half timesteps and compares to the current result

use stardata,only: debug
use embryodata

implicit none

real,dimension(3,nbodies),intent(in) :: position,velocity

integer :: ibody,ix
real :: halfdt,error
real, dimension(3,nbodies) :: testpos1,testvel1,testpos2,testvel2

halfdt = dt_nbody/2

call nbody_integrate(halfdt,pos,vel,testpos1,testvel1)
call nbody_integrate(halfdt,testpos1,testvel1,testpos2,testvel2)

! Compute error between half timestep and full timestep for each particle

error = 0.0
maxerror = -1.0e30

do ibody=1,nbodies

   error = 0.0
   do ix=1,3

      error = error + (position(ix,ibody)-testpos2(ix,ibody))*(position(ix,ibody)-testpos2(ix,ibody))
      error = error + (velocity(ix,ibody)-testvel2(ix,ibody))*(velocity(ix,ibody)-testvel2(ix,ibody))

   enddo

   error = sqrt(error)

   if(error>maxerror) maxerror = error
enddo

! Compute new deltat based on this error level
! If current error below user defined tolerance, then dt is increased
! If current error above tolerance, then dt is decreased

if(maxerror>small) then
   dt_nbody = dt_nbody*abs(tolerance/maxerror)**0.2
endif

if(maxerror>tolerance) then
   if(debug=='y') then
      print*,'reducing timestep'
      print*,tolerance,maxerror,dt_nbody
   endif

   dt_nbody = dt_nbody*0.1
endif

end subroutine nbody_timestep


! Name = ARPIT KUMAR JAIN  ROLL No = 180122009
! Code for Question 2 Simple Harmonic Oscillator --> Second Order ODEs (x" = -x)

MODULE precision
    IMPLICIT NONE

    ! dp = double precisiona
    INTEGER, PARAMETER:: dp = SELECTED_REAL_KIND(12)
END MODULE precision

! Tp --> Time Period = 2π
! h  --> step size = 0.02T
MODULE constants
    USE precision
    IMPLICIT NONE

    REAL(KIND = dp), PARAMETER :: pi = acos(-1.0), Tp = 2 * pi
    REAL(KIND = dp):: h = 0.02 * Tp
    REAL(KIND = dp):: tinitial = 0.0, xinitial = 1.0, pinitial = 0.0
END MODULE constants

PROGRAM Simple_Harmonic_Oscillator
    USE precision
    USE constants
    IMPLICIT NONE

    ! t --> Time
    ! x0 --> value at starting point
    ! p0 --> value of X' at starting point
    ! x1 --> new value of x
    ! p1 --> new value of p
    REAL(KIND = dp):: t, x0, p0, x1, p1

    ! i --> iterator,, Nt --> number of iteration or Grid Points
    INTEGER:: i, Nt

    Nt = 500

    ! Propagating Euler Method Solution
    t = tinitial
    x0 = xinitial
    p0 = pinitial
    OPEN(UNIT = 10, FILE = 'Euler_P_vs_X.txt')
    OPEN(UNIT = 11, FILE = 'Euler_2E_vs_time.txt')
    OPEN(UNIT = 12, FILE = 'Euler_X_vs_time.txt')
    DO i = 1, Nt

        t = t + h
        CALL Euler_Method(t, x0, p0, x1, p1)

        WRITE(10, *) x1, p1
        WRITE(11, *) t/Tp, p1**2.0_dp + x1**2.0_dp
        WRITE(12, *) t/Tp, x1

        ! Update values for next itration
        x0 = x1
        p0 = p1
    ENDDO
    CLOSE(10)
    CLOSE(11)
    CLOSE(12)

    ! Propagating Runge-Kutta 4 Method Solution
    t = tinitial
    x0 = xinitial
    p0 = pinitial
    OPEN(UNIT = 20, FILE = 'RK4_P_vs_X.txt')
    OPEN(UNIT = 21, FILE = 'RK4_2E_vs_time.txt')
    OPEN(UNIT = 22, FILE = 'RK4_X_vs_time.txt')
    DO i = 1, Nt

        t = t + h
        CALL RK4_Method(t, x0, p0, x1, p1)

        WRITE(20, 5) x1, p1
        WRITE(21, 5) t/Tp, p1**2.0_dp + x1**2.0_dp
        WRITE(22, 5) t/Tp, x1
        5 FORMAT(f7.4, 3x, f7.4)

        ! Update values for next itration
        x0 = x1
        p0 = p1
    ENDDO
    CLOSE(20)
    CLOSE(21)
    CLOSE(22)

    CONTAINS
    SUBROUTINE Euler_Method(t, x0, p0, x1, p1)
        USE precision
        USE constants
        IMPLICIT NONE

        REAL(KIND = dp):: t, x0, p0, x1, p1

        x1 = x0 + h * dx_by_dt(t, x0, p0)
        p1 = p0 + h * dp_by_dt(t, x0, p0)
    END SUBROUTINE Euler_Method

    SUBROUTINE RK4_Method(t, x0, p0, x1, p1)
        USE precision
        USE constants
        IMPLICIT NONE

        REAL(KIND = dp):: t, x0, p0, x1, p1
        REAL(KIND = dp):: s1x, s2x, s3x, s4x, s1p, s2p, s3p, s4p

        s1x = h * dx_by_dt(t, x0, p0)
        s1p = h * dp_by_dt(t, x0, p0)

        s2x = h * dx_by_dt(t + h/2.0_dp, x0 + s1x/2.0_dp, p0 + s1p/2.0_dp)
        s2p = h * dp_by_dt(t + h/2.0_dp, x0 + s1x/2.0_dp, p0 + s1p/2.0_dp)

        s3x = h * dx_by_dt(t + h/2.0_dp, x0 + s2x/2.0_dp, p0 + s2p/2.0_dp)
        s3p = h * dp_by_dt(t + h/2.0_dp, x0 + s2x/2.0_dp, p0 + s2p/2.0_dp)

        s4x = h * dx_by_dt(t + h, x0 + s3x, p0 + s3p)
        s4p = h * dp_by_dt(t + h, x0 + s3x, p0 + s3p)

        x1 = x0 + (s1x + 2.0_dp * s2x + 2.0_dp * s3x + s4x)/6.0_dp
        p1 = p0 + (s1p + 2.0_dp * s2p + 2.0_dp * s3p + s4p)/6.0_dp
    END SUBROUTINE RK4_Method

    FUNCTION dx_by_dt(t, x, p)
        IMPLICIT NONE

        REAL(KIND = dp):: dx_by_dt, t, x, p

        ! No change in t and x
        t = t
        x = x

        ! x' = p
        dx_by_dt = p
        RETURN
    END FUNCTION dx_by_dt

    FUNCTION dp_by_dt(t, x, p)
        IMPLICIT NONE

        REAL(KIND = dp):: dp_by_dt, t, x, p

        ! No change in t and p
        t = t
        p = p

        ! P' = -x
        dp_by_dt = -x
        RETURN
    END FUNCTION dp_by_dt

END PROGRAM Simple_Harmonic_Oscillator


! Program to test SELECTED_REAL_KIND intrinsic function.
Program test_sr_kind
  integer res, i4, i8, t
  real*4 r4
  real*8 r8

  i4 = int (log10 (huge (r4)))
  t = - int (log10 (tiny (r4)))
  if (i4 .gt. t) i4 = t

  i8 = int (log10 (huge (r8)))
  t = - int (log10 (tiny (r8)))
  if (i8 .gt. t) i8 = t

  res = selected_real_kind (r = i4)
  if (res .ne. 4) call abort

  res = selected_real_kind (r = i8)
  if (res .ne. 8) call abort

! We can in fact have kinds wider than r8.  How do we want to check?
! res = selected_real_kind (r = (i8 + 1))
! if (res .ne. -2) call abort

  res = selected_real_kind (p = precision (r4))
  if (res .ne. 4) call abort

  res = selected_real_kind (p = precision (r4), r = i4)
  if (res .ne. 4) call abort

  res = selected_real_kind (p = precision (r4), r = i8)
  if (res .ne. 8) call abort

! res = selected_real_kind (p = precision (r4), r = i8 + 1)
! if (res .ne. -2) call abort

  res = selected_real_kind (p = precision (r8))
  if (res .ne. 8) call abort

  res = selected_real_kind (p = precision (r8), r = i4)
  if (res .ne. 8) call abort

  res = selected_real_kind (p = precision (r8), r = i8)
  if (res .ne. 8) call abort

! res = selected_real_kind (p = precision (r8), r = i8 + 1)
! if (res .ne. -2) call abort

! res = selected_real_kind (p = (precision (r8) + 1))
! if (res .ne. -1) call abort

! res = selected_real_kind (p = (precision (r8) + 1), r = i4)
! if (res .ne. -1) call abort

! res = selected_real_kind (p = (precision (r8) + 1), r = i8)
! if (res .ne. -1) call abort

! res = selected_real_kind (p = (precision (r8) + 1), r = i8 + 1)
! if (res .ne. -3) call abort

end


program P13301
    implicit none

    integer(8) :: current, prev, temp
    integer :: n
    integer :: i

    read (*,*) n

    current = 4
    prev = 2
    do i = 2, n
        temp = current
        current = current + prev
        prev = temp
    end do
    write (*, '(I0)') current

end program P13301


!!# FUNCTION MODULE: <FUN_Factorial>
MODULE FUN_Factorial

!!## PURPOSE
!! Defines function Factorial(k) which returns a real double precision
!! for integer k.  If the factorial does not exist Infinity is returned.

!!## DETAILS
!! @ The kind of real Factorial(k) is equal to the kind of integer k.
!! @ A check is made to make sure k has a factorial that is less than HUGE(k).

!!## PARAMETERS
!! @ kind of the real function return value
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp         !!((01-A-KND_IntrinsicTypes.f90))

!!## MODULES
USE FUN_FactorialInt,ONLY: MAX_I4,MAX_I8,FactorialInt !!((05-B-FUN_FactorialInt.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## FUNCTION OVERLOADING
INTERFACE Factorial
 MODULE PROCEDURE Factorial_I4
 MODULE PROCEDURE Factorial_I8
ENDINTERFACE
PUBLIC :: Factorial

CONTAINS

PURE ELEMENTAL FUNCTION Factorial_I4( x ) RESULT(y)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I4          !!((01-A-KND_IntrinsicTypes.f90))
INTEGER,PARAMETER :: MAX   = MAX_I4
INCLUDE "06-B-FUN_Factorial.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_Factorial.f90.bdy"
!!--end--
ENDFUNCTION

PURE ELEMENTAL FUNCTION Factorial_I8( x ) RESULT(y)
USE KND_IntrinsicTypes,ONLY: KIND_I=>KIND_I8          !!((01-A-KND_IntrinsicTypes.f90))
INTEGER,PARAMETER :: MAX   = MAX_I8
INCLUDE "06-B-FUN_Factorial.f90.hdr"
!!--begin--
INCLUDE "06-B-FUN_Factorial.f90.bdy"
!!--end--
ENDFUNCTION

ENDMODULE


module misc
  use iso_fortran_env, only: wp => real64
  implicit none

  real(wp), parameter :: pi = 4._wp*datan(1._wp)

contains

  subroutine mysub(n, t, y, dy)
    integer, intent(in)                 :: n
    real(wp), intent(in)                :: t
    real(wp), intent(in), dimension(n)  :: y
    real(wp), intent(out), dimension(n) :: dy

    ! call simple_trig(n, t, y, dy)
    ! call simple_ode(n, t, y, dy)
    ! call vanderpol(n, t, y, dy)
    ! call lorenz(n, t, y, dy)
    ! call brusselator(n, t, y, dy)
    ! call stiff(n, t, y, dy)
    call robertson(n, t, y, dy)

    return
  end subroutine mysub

  subroutine simple_trig(n, t, y, dy)
    integer, intent(in)                 :: n
    real(wp), intent(in)                :: t
    real(wp), intent(in), dimension(n)  :: y
    real(wp), intent(out), dimension(n) :: dy

    dy(1) = dcos(t)
    dy(2) = -dsin(t)

    return
  end subroutine simple_trig

  subroutine simple_ode(n, t, y, dy)
    integer, intent(in)                 :: n
    real(wp), intent(in)                :: t
    real(wp), intent(in), dimension(n)  :: y
    real(wp), intent(out), dimension(n) :: dy

    dy(1) = y(2)
    dy(2) = -y(1)
    dy(3) = -y(2)

    return
  end subroutine simple_ode

  subroutine vanderpol(n, t, y, dy)
    integer, intent(in)                 :: n
    real(wp), intent(in)                :: t
    real(wp), intent(in), dimension(n)  :: y
    real(wp), intent(out), dimension(n) :: dy

    real(wp), parameter                 :: mu = 10._wp
    real(wp), parameter                 :: A = 0._wp
    real(wp), parameter                 :: omega = 2._wp*pi/11_wp

    dy(1) = y(2)
    dy(2) = mu * (1._wp-y(1)*y(1)) * y(2) - y(1) + A*dsin(t*omega)

    return
  end subroutine vanderpol

  subroutine lorenz(n, t, y, dy)
    integer, intent(in)                 :: n
    real(wp), intent(in)                :: t
    real(wp), intent(in), dimension(n)  :: y
    real(wp), intent(out), dimension(n) :: dy

    real(wp), parameter                 :: sigma = 10._wp
    real(wp), parameter                 :: rho = 28._wp
    real(wp), parameter                 :: beta = 8._wp/3._wp

    dy(1) = sigma * (y(2)-y(1))
    dy(2) = y(1) * (rho-y(3)) - y(2)
    dy(3) = y(1)*y(2) - beta*y(3)

    return
  end subroutine lorenz

  subroutine brusselator(n, t, y, dy)
    integer, intent(in)                 :: n
    real(wp), intent(in)                :: t
    real(wp), intent(in), dimension(n)  :: y
    real(wp), intent(out), dimension(n) :: dy

    dy(1) = 1._wp + y(1)*y(1)*y(2) - 4._wp*y(1)
    dy(2) = 3._wp*y(1) - y(1)*y(1)*y(2)

    return
  end subroutine brusselator

  subroutine stiff(n, t, y, dy)
    integer, intent(in)                 :: n
    real(wp), intent(in)                :: t
    real(wp), intent(in), dimension(n)  :: y
    real(wp), intent(out), dimension(n) :: dy

    dy(1) = -50._wp * ( y(1) - dcos(t) )

    return
  end subroutine stiff

  subroutine robertson(n, t, y, dy)
    integer, intent(in)                 :: n
    real(wp), intent(in)                :: t
    real(wp), intent(in), dimension(n)  :: y
    real(wp), intent(out), dimension(n) :: dy

    real(wp), dimension(n) :: k

    k = [ 4d-2, 3d7, 1d4 ]

    dy(1) = - k(1) * y(1) + k(3) * y(2) * y(3)
    dy(2) =   k(1) * y(1) - k(3) * y(2) * y(3) - k(2) * y(2) * y(2)
    dy(3) =                                      k(2) * y(2) * y(2)

    ! print*, y
    ! print*, dy
    ! stop

    return
  end subroutine robertson

end module misc


MODULE Conversion
  IMPLICIT NONE
  CHARACTER(36) :: alphanum = "0123456789abcdefghijklmnopqrstuvwxyz"

  CONTAINS

  FUNCTION ToDecimal(base, instr)
    INTEGER :: ToDecimal
    INTEGER :: length, i, n, base
    CHARACTER(*) :: instr

    ToDecimal = 0
    length = LEN(instr)
    DO i = 1, length
      n = INDEX(alphanum, instr(i:i)) - 1
      n = n * base**(length-i)
      Todecimal = ToDecimal + n
    END DO
  END FUNCTION ToDecimal

  FUNCTION ToBase(base, number)
    CHARACTER(31) :: ToBase
    INTEGER :: base, number, i, rem

    ToBase = "                               "
    DO i = 31, 1, -1
      IF(number < base) THEN
        ToBase(i:i) = alphanum(number+1:number+1)
        EXIT
      END IF
      rem = MOD(number, base)
      ToBase(i:i) = alphanum(rem+1:rem+1)
      number = number / base
    END DO
    ToBase = ADJUSTL(ToBase)
  END FUNCTION ToBase

END MODULE Conversion

PROGRAM Base_Convert
  USE Conversion

  WRITE (*,*) ToDecimal(16, "1a")
  WRITE (*,*) ToBase(16, 26)

END PROGRAM


! This file is F-compatible, except for upper/lower case conventions.
!--------------------------------------------------------------------
Module Volume_Computation

USE Precision_Model, ONLY: stnd

Implicit NONE

PRIVATE
PUBLIC :: VOLUME

CONTAINS
      FUNCTION VOLUME(DIMENS,GEOMETRY,VERTIC) RESULT(Value)
!***BEGIN PROLOGUE VOLUME
!***PURPOSE  To compute the volume of a polytope
!***AUTHORS
!        Ronald Cools                     Alan Genz
!        Dept. of Computer Science        Computer Science Department
!        Katholieke Universiteit Leuven   Washington State University
!        Celestijnenlaan 200A             Pullman, WA 99164-2752
!        B-3001 Heverlee, Belgium         USA
!
!***REVISION DATE  950419   (YYMMDD) (Fortran90 transformation)
!***REVISION DATE  980408   (YYMMDD) (F         transformation)
!***DESCRIPTION VOLUME
!
!   GEOMETRY = 1 : the VERTICes specify a simplex
!   GEOMETRY = 2 : the VERTICes specify a cube
!   GEOMETRY = 3 : the VERTICes specify an octahedron
!
!  WARNING: If a region of an unsupported shape is presented,
!           then this function returns 0.
!           This is the only indication of a failure !
!
!   Global variables.
!
      INTEGER, INTENT(IN) :: DIMENS,GEOMETRY
      REAL(kind=stnd), DIMENSION(:,:), INTENT(IN) :: VERTIC
      REAL(kind=stnd) :: Value
!
!   Local variables.
!
      INTEGER         :: I,J,K,PIVPOS,FACDIM
      REAL(kind=stnd) :: MULT,VOL
      REAL(kind=stnd), DIMENSION(DIMENS) :: TMP
      REAL(kind=stnd), DIMENSION(DIMENS,DIMENS) :: WORK

      IF ((GEOMETRY == 1) .OR. (GEOMETRY == 2) .OR. (GEOMETRY == 3)) THEN
          SELECT CASE (DIMENS)
          CASE (1) !    Compute length of an interval
              Value = ABS(VERTIC(1,2)-VERTIC(1,1))

          CASE (2) !    Compute area of a rectangle.
              Value = ABS((VERTIC(1,2)-VERTIC(1,1))*                 &
                       (VERTIC(2,3)-VERTIC(2,1))-                    &
                       (VERTIC(2,2)-VERTIC(2,1))*                    &
                       (VERTIC(1,3)-VERTIC(1,1)))

          CASE (3) !    Compute the volume of a cube.
              Value = ABS((VERTIC(1,2)-VERTIC(1,1))*                 &
                       ((VERTIC(2,3)-VERTIC(2,1))* (VERTIC(3,        &
                       4)-VERTIC(3,1))- (VERTIC(2,4)-VERTIC(2,       &
                       1))* (VERTIC(3,3)-VERTIC(3,1)))-              &
                       (VERTIC(2,2)-VERTIC(2,1))*                    &
                       ((VERTIC(1,3)-VERTIC(1,1))* (VERTIC(3,        &
                       4)-VERTIC(3,1))- (VERTIC(1,4)-VERTIC(1,       &
                       1))* (VERTIC(3,3)-VERTIC(3,1)))+              &
                       (VERTIC(3,2)-VERTIC(3,1))*                    &
                       ((VERTIC(1,3)-VERTIC(1,1))* (VERTIC(2,        &
                       4)-VERTIC(2,1))- (VERTIC(1,4)-VERTIC(1,       &
                       1))* (VERTIC(2,3)-VERTIC(2,1))))

          CASE DEFAULT !  Compute the volume of a DIMENS-dimensional cube
              DO J = 1,DIMENS
                 WORK(1:DIMENS,J) = VERTIC(1:DIMENS,J+1) - VERTIC(1:DIMENS,1)
              END DO
              VOL = 1
              DO K = 1,DIMENS
                  PIVPOS = K
                  DO J = K + 1,DIMENS
                     IF (ABS(WORK(K,J)) > ABS(WORK(K,PIVPOS))) THEN
                        PIVPOS = J
                     END IF
                  END DO
                  TMP(K:DIMENS) = WORK(K:DIMENS,K)
                  WORK(K:DIMENS,K) = WORK(K:DIMENS,PIVPOS)
                  WORK(K:DIMENS,PIVPOS) = TMP(K:DIMENS)
                  VOL = VOL*WORK(K,K)
                  DO J = K + 1,DIMENS
                      MULT = WORK(K,J)/WORK(K,K)
                      WORK(K+1:DIMENS,J) = WORK(K+1:DIMENS,J) - MULT*WORK(K+1:DIMENS,K)
                  END DO
              END DO
              Value = ABS(VOL)
          END SELECT
          IF ((GEOMETRY == 1) .OR. (GEOMETRY == 3)) THEN
!
!            The volume of an DIMENS-dimensional simplex is the
!            DIMENS! part of the volume of the cube.
!
              FACDIM = DIMENS
              DO I = 2,DIMENS - 1
                  FACDIM = FACDIM*I
              END DO
              Value = Value/FACDIM
          END IF
          IF (GEOMETRY == 3) THEN
!
!            The volume of an DIMENS-dimensional octahedron is
!            2**(DIMENS-1) times the volume of the simplex.
!
              Value = Value*2**(DIMENS-1)
          END IF
      ELSE
          Value = 0
      END IF
      RETURN
      END FUNCTION VOLUME

END MODULE Volume_Computation


module user_functions
    implicit none
contains

real function f( x )
    real, intent(in) :: x
    f = x - x**2 + sin(x)
end function f

end module user_functions


!> @ingroup quick_sort_flat
!>
!> @brief
!> Run a flat three way quick sort on a vector of real values.
!>
!> @details
!> Run a flat three way quick sort on a vector of real values to sort them in a specified order.
!>
!> @param vec
!> The vector to be sorted.
!>
!> @param ascending
!> Indicates if the ordering is ascending or decending.
!>
!> | Value | Meaning         |
!> |:-----:| :-------------- |
!> | true  | Ascending order |
!> | false | Decending order |
!>
!> @author Arin R. Bratt
!> @date 11/07/2014

pure subroutine quick_sort_flat_real(vec,ascending)
  ! Arguments
  real, intent(inout) :: vec(:)
  logical, intent(in) :: ascending

  ! Main
  if (ascending) then
     call quick_sort_flat_asc_real(vec)
  else
     call quick_sort_flat_dec_real(vec)
  end if
end subroutine quick_sort_flat_real


! test_intervals.f90 --
!     Test for the interval_arithmetic module
!
!     Also find a root of some equation via Newton-Raphson
!
module root_functions
    use select_precision
contains

real(wp) function g( x )
    real(wp), intent(in) :: x

    g = x**2 - 2.0

end function g

real(wp) function gprime( x )
    real(wp), intent(in) :: x

    gprime = 2.0*x

end function gprime

end module root_functions

program test_intervals
    use root_functions
    use interval_arithmetic
    use select_precision

    implicit none

    type(INTERVAL)  :: x, y, root
    integer         :: i
    logical         :: found

    x = intval(1.0, 2.0)
    y = intval(2.0, 4.0)

    write(*,*) 'x   = ', x
    write(*,*) 'y   = ', y
    write(*,*) 'x+y = ', x+y
    write(*,*) 'x-y = ', x-y
    write(*,*) 'x*y = ', x*y
    write(*,*) 'x/y = ', x/y

    call find_root( g, gprime, x, 1.0e-6_wp, root, found )
    write(*,*) 'Equation: x**2 - 2 = 0'
    write(*,*) 'Root: ', root, ' - expected: ', sqrt(2.0_wp)

    write(*,*) 'Elementary functions:'
    write(*,*) 'x =', x
    write(*,*) 'exp(x) = ', exp(x)
    write(*,*) 'log(x) = ', log(x)
    write(*,*) 'sin(x) = ', sin(x)
    write(*,*) 'tan(x) = ', tan(x)
    write(*,*) 'y =', y
    write(*,*) 'cos(y) = ', cos(y)

end program


subroutine get_laplacian(q, q_laplacian)

! Calculate Laplacian of q at cell centers.  Fills ghost cells within the
! outermost layer.

    !$ use omp_lib
    implicit none

    integer :: mx, my, mbc, meqn
    double precision :: x_lower, y_lower, dx, dy
    common /claw_config/ mx, my, mbc, x_lower, y_lower, dx, dy, meqn

    double precision, dimension(1-mbc:mx+mbc,1-mbc:my+mbc), intent(in) :: q
    double precision, dimension(1-mbc:mx+mbc,1-mbc:my+mbc), intent(out) :: q_laplacian

    integer :: ix, iy

    !$omp parallel do private(ix)
    do iy = 2-mbc,my+mbc-1
        do ix = 2-mbc,mx+mbc-1
            q_laplacian(ix,iy) = (q(ix-1,iy) - 2.d0*q(ix,iy) + q(ix+1,iy)) / dx**2
            q_laplacian(ix,iy) = q_laplacian(ix,iy) +  &
                                 (q(ix,iy-1) - 2.d0*q(ix,iy) + q(ix,iy+1)) / dy**2
        end do
    end do

end subroutine get_laplacian


    program demo_sinh
    use, intrinsic :: iso_fortran_env, only : &
    & real_kinds, real32, real64, real128
    implicit none
    real(kind=real64) :: x = - 1.0_real64
    real(kind=real64) :: nan, inf
    character(len=20) :: line

       print *, sinh(x)
       print *, (exp(x)-exp(-x))/2.0

       ! sinh(3) is elemental and can handle an array
       print *, sinh([x,2.0*x,x/3.0])

       ! a NaN input returns NaN
       line='NAN'
       read(line,*) nan
       print *, sinh(nan)

       ! a Inf input returns Inf
       line='Infinity'
       read(line,*) inf
       print *, sinh(inf)

       ! an overflow returns Inf
       x=huge(0.0d0)
       print *, sinh(x)

    end program demo_sinh


    function fcgd(xx)

      implicit none

      real :: fcgd          !             |
      real :: tn            !             |
      real :: top           !             |
      real :: tx            !             |
      real :: qq            !             |
      real :: xx            !             |

      tn = -5.
	  top = 35.
      tx = 50.
      qq = (tn - top)/(top - tx)
	  fcgd = ((xx-tn)**qq)*(tx-xx)/(((top-tn)**qq)*(tx-top))
      if (fcgd < 0.) fcgd = 0.
    end function


	SUBROUTINE RTTOXY  ( r, theta, x, y, iret )
C************************************************************************
C* RTTOXY								*
C* 									*
C* This subroutine converts r, theta in polar coordinates to x, y	*
C* in linear coordinates.						*
C*									*
C* RTTOXY  ( R, THETA, X, Y, IRET )					*
C*									*
C* Input parameters:							*
C* 	R		REAL		Value of r			*
C*	THETA		REAL		Value of theta in degrees	*
C*									*
C* Output parameters:							*
C*	X		REAL		Value of x			*
C*	Y		REAL		Value of y			*
C* 	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* M. desJardins/GSFC	10/86						*
C* K. Brill/EMC		 3/96	Input and output variables can be same	*
C************************************************************************
	INCLUDE		'ERROR.PRM'
	INCLUDE		'GEMPRM.PRM'
C-------------------------------------------------------------------------
	iret = NORMAL
C
C*	Do transformation.
C
	rr = r
	th = theta
	x = rr * COS ( th * DTR )
	y = rr * SIN ( th * DTR )
C*
	RETURN
	END


    program demo_log
    implicit none
      real(kind(0.0d0)) :: x = 2.71828182845904518d0
      complex :: z = (1.0, 2.0)
      write(*,*)x, log(x)    ! will yield (approximately) 1
      write(*,*)z, log(z)
    end program demo_log