module runge_kutta
  use iso_fortran_env, only: wp => real64
  use rk_constants, only: classic_rk4, &
                        & three_eighths_rk4, &
                        & midpoint, &
                        & heun, &
                        & ralston

  use rk_constants, only: heun_euler, &
                        & fehlbery_rk12, &
                        & bogacki_shampine, &
                        & fehlbery_rk45, &
                        & cash_karp_rk45, &
                        & dormand_prince_rk45, &
                        & fehlbery_rk78

  use rk_constants, only: trapezoidal, &
                        & gauss_legendre4, &
                        & gauss_legendre6

  use nonlinalg, only: nonlinsolve

  implicit none

  interface
    subroutine sub_interf(n, t, y, dy)
      import wp
      integer,  intent(in)                  :: n
      real(wp), intent(in)                  :: t
      real(wp), intent(in),   dimension(n)  :: y
      real(wp), intent(out),  dimension(n)  :: dy
    end subroutine
  end interface

contains

  subroutine rk_wrapper(n, num_t, t, y, dysub)
    ! Dummy arguments
    integer,  intent(in)                          :: n, num_t
    real(wp), intent(inout),  dimension(num_t)    :: t
    real(wp),                 dimension(num_t, n) :: y
    procedure(sub_interf)                         :: dysub

    ! Local arguments
    integer                                       :: ii, m, p
    real(wp)                                      :: dt
    real(wp), dimension(2)                        :: tspan
    real(wp), dimension(n)                        :: yy
    real(wp), dimension(:),   allocatable         :: c, b, bstar
    real(wp), dimension(:,:), allocatable         :: a
    logical                                       :: explicit
    logical,  dimension(:,:), allocatable         :: diag_upper

    ! Get the tableau coefficients associated with a runge kutta implementation
    ! call heun_euler(a, b, bstar, c, m, p)
    ! call fehlbery_rk12(a, b, bstar, c, m, p)
    ! call bogacki_shampine(a, b, bstar, c, m, p)
    ! call fehlbery_rk45(a, b, bstar, c, m, p)
    call dormand_prince_rk45(a, b, bstar, c, m, p)
    ! call fehlbery_rk78(a, b, bstar, c, m, p)

    ! call heun(a, b, c, m)
    ! call three_eighths_rk4(a, b, c, m)

    ! call trapezoidal(a, b, bstar, c, m, p)
    ! call gauss_legendre4(a, b, bstar, c, m, p)
    ! call gauss_legendre6(a, b, bstar, c, m, p)

    explicit = check_explicit(a, m)
    ! explicit = .false.

    ! do ii = 1, m
    !   print*, a(ii,:)
    ! end do

    ! EDIT 10-11-2016: change dt to be the minimum value between t(2)-t(1) and
    ! 1d-2 because sometimes you only want a very sparse output of data, and
    ! that could overshoot a good initial guess. This should be smarter
    dt = minval([t(2) - t(1), 1d-2])

    do ii = 1, num_t-1
      yy = y(ii,:)
      tspan = t(ii:ii+1)

      call rk_adaptive(n, tspan, dt, yy, dysub, a, b, bstar, c, m, p, explicit)
      ! call rk_explicit(n, t(ii), t(ii+1)-t(ii), yy, dysub, a, b, c, m, explicit)

      y(ii+1, :) = yy

      ! if (ii == 1) stop
    end do

    if (allocated(a)) deallocate(a)
    if (allocated(b)) deallocate(b)
    if (allocated(bstar)) deallocate(bstar)
    if (allocated(c)) deallocate(c)

    return
  end subroutine rk_wrapper

  subroutine rk_adaptive(n, tspan, dt, y, dysub, a, b, bstar, c, m, p, explicit)
    ! Dummy arguments
    integer,  intent(in)                      :: n, m, p
    real(wp), intent(inout)                   :: dt
    real(wp), intent(in),     dimension(2)    :: tspan
    real(wp), intent(inout),  dimension(n)    :: y
    real(wp), intent(in),     dimension(m)    :: c, b, bstar
    real(wp), intent(in),     dimension(m,m)  :: a
    procedure(sub_interf)                     :: dysub
    logical                                   :: explicit

    ! Local arguments
    real(wp)                              :: t, error
    ! real(wp), parameter                   :: eps_abs = epsilon(1e0)
    ! real(wp), parameter                   :: eps_abs = 1d-7
    real(wp), parameter                   :: eps_abs = sqrt(epsilon(1._wp))
    ! real(wp), parameter                   :: eps_rel = epsilon(1e0)
    ! real(wp), parameter                   :: eps_rel = 1d-7
    real(wp), parameter                   :: eps_rel = sqrt(epsilon(1._wp))
    real(wp), dimension(n)                :: dummy_y, y_star

    integer                               :: eval, num_dt
    integer, parameter                    :: max_eval = 500
    real(wp)                              :: s, gamma, sc, maxy
    logical                               :: last

    num_dt = 1
    t = tspan(1)
    last = .false.

    ! Begin loop to solve for y until end of timestep (tend)
    do while ( t <= tspan(2) )

      ! Begin loop to reach convergence from a specified point in time
      do eval = 1, max_eval
        ! print*, 'eval     = ', eval
        ! print*, 'time     = ', t
        ! print*, 'y        = ', y
        ! print*, 'dt       = ', dt
        ! k(m,n) is recalculated in each of these rk loops. Maybe that's a
        ! performance issue
        dummy_y = y
        y_star  = y
        call rk_explicit(n, t, dt, dummy_y, dysub, a, b,      c, m, explicit)
        call rk_explicit(n, t, dt, y_star,  dysub, a, bstar,  c, m, explicit)

        ! print*, 'dummy_y  = ', dummy_y
        ! print*, 'y_star   = ', y_star

        ! error = maxval(abs(dummy_y - y_star))
        error = norm2(dummy_y - y_star)
        maxy = maxval([ abs(dummy_y), abs(y_star) ])

        gamma = 0.25_wp ** (1._wp / real(p,wp))
        ! gamma = 0.9_wp

        sc = eps_abs + maxy * eps_rel

        s = gamma * (sc/error) ** ( 1._wp/real(p,wp) )
        ! s = eps_abs*dt / &
        !     & (2._wp * (tspan(2) - tspan(1)) * error)
        ! print*, 'error    = ', error
        ! print*, 'maxy     = ', maxy
        ! print*, 'sc       = ', sc
        ! print*, 's        = ', s
        ! print*,
        ! stop

        ! Adjust dt based on estimation of error
        if ( s >= 2._wp ) then
          t = t + dt
          y = y_star
          dt = dt * 2._wp
          ! print*, 'Adjusted dt with factor of 2'
          exit
        else if ( s < 2._wp .and. s >= 0.999_wp ) then
      ! else if ( s < 2._wp .and. s >= 1._wp ) then
          t = t + dt
          y = y_star
          dt = dt * s
          ! print 121, 'Adjusted dt with factor of ', s
          exit
        else if ( s <= 1._wp ) then
          dt = dt * s
          ! print 121, 'Adjusted dt with factor of ', s
        end if

        if ( eval == max_eval ) then
          print*, 'dummy_y  = ', dummy_y
          print*, 'y_star   = ', y_star
          print*, 'error    = ', error
          print*, 'maxy     = ', maxy
          print*, 'sc       = ', sc
          print*, 's        = ', s
          stop "Warning, max eval iterations reached!"
        end if

      end do

      write(22,*) t, dt, y

      ! num_dt = num_dt + 1
      ! print 120, t, tspan, dt, y

      ! Make sure t does not overshoot tspan(2) (i.e. end of timestep)
      if ( last ) then
        exit
      end if

      if ( t + dt > tspan(2) ) then
        dt = tspan(2) - t
        last = .true.
      end if

    end do

    ! print*, num_dt
    ! print 120, t, tspan, dt, y
    ! stop

    ! deallocate(a, b, bstar, c)
    120 format (1x,6(e14.6))
    121 format (a, e14.6)

    return
  end subroutine rk_adaptive

  subroutine rk_explicit(n, t, dt, y, dysub, a, b, c, m, explicit)
    ! Dummy arguments
    integer,  intent(in)                      :: n, m
    real(wp), intent(in)                      :: t, dt
    real(wp), intent(inout),  dimension(n)    :: y
    real(wp), intent(in),     dimension(m)    :: b, c
    real(wp), intent(in),     dimension(m,m)  :: a
    procedure(sub_interf)                     :: dysub
    logical                                   :: explicit

    ! Local arguments
    integer                   :: ii
    real(wp), dimension(n)    :: dy
    real(wp), dimension(m,n)  :: k

    ! Initialize guess for the values of k, just k = dy0 = f(t0, y0)
    call dysub(n, t, y, dy)
    do ii = 1, m
      k(ii, :) = dy
    end do

    ! Calculate values of k
    if ( explicit ) then
      call calc_k(n, t, dt, y, dysub, a, b, c, m, k)
    else
      call calc_k_implicit(n, t, dt, y, dysub, a, b, c, m, k)
    end if

    ! Calculate y(t+dt) using y(t) and k()'s
    y = y + [( dt*dot_product(b,k(:,ii)), ii = 1, n )]

    return
  end subroutine rk_explicit

  subroutine calc_k(n, t, dt, y, dysub, a, b, c, m, k)
    ! Dummy arguments
    integer,  intent(in)                      :: n, m
    real(wp), intent(in)                      :: t, dt
    real(wp), intent(inout),  dimension(n)    :: y
    real(wp), intent(in),     dimension(m)    :: b, c
    real(wp), intent(in),     dimension(m,m)  :: a
    real(wp), intent(inout),  dimension(m,n)  :: k
    procedure(sub_interf)                     :: dysub

    ! Local arguments
    integer                   :: ii, jj
    real(wp)                  :: dummy_t
    real(wp), dimension(n)    :: dummy_y
    real(wp), dimension(n)    :: dy

    dummy_y = y

    do ii = 1, m

      dummy_t = t + dt*c(ii)
      do jj = 1, ii
        dummy_y = dummy_y + dt*a(ii,jj)*k(jj,:)
      end do

      call dysub(n, dummy_t, dummy_y, dy)
      k(ii, :) = dy

    end do

    return
  end subroutine calc_k

  subroutine calc_k_implicit(n, t, dt, y, dysub, a, b, c, m, k)
    ! Dummy arguments
    integer,  intent(in)                      :: n, m
    real(wp), intent(in)                      :: t, dt
    real(wp), intent(inout),  dimension(n)    :: y
    real(wp), intent(in),     dimension(m)    :: b, c
    real(wp), intent(in),     dimension(m,m)  :: a
    real(wp), intent(inout),  dimension(m,n)  :: k
    procedure(sub_interf)                     :: dysub

    ! Local arguments
    integer                   :: ii, jj
    real(wp)                  :: dummy_t
    real(wp), dimension(n)    :: dummy_y
    real(wp), dimension(n)    :: dy

    ! print*, "I'm in the implicit solver", size(k), m, n
    ! print*,

    ! do ii = 1, m
    !   print*, k(ii,:)
    ! end do
    ! print*,

    ! dummy_k = reshape(k, [m*n])

    k = reshape(nonlinsolve(calc_k_wrapper, m*n, reshape(k, [m*n])), [m,n])

    ! print*, calc_k_wrapper(m*n, reshape(k, [m*n]))

    ! do ii = 1, m
    !   print*, k(ii,:)
    ! end do
    ! print*,

    ! stop

  contains

    function calc_k_wrapper(mn, dummy_k) result(F)
      ! Dummy arguments
      integer,  intent(in)                :: mn
      real(wp), intent(in), dimension(mn) :: dummy_k
      real(wp),             dimension(mn) :: F

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

      k0 = reshape(dummy_k, [m, n])
      k = k0

      call calc_k(n, t, dt, y, dysub, a, b, c, m, k0)

      ! do ii = 1,m
      !   print*, k(ii,:) - k0(ii,:)
      ! end do
      ! print*,

      F = reshape(k - k0, [m*n])

      return
    end function calc_k_wrapper

  end subroutine calc_k_implicit

  function check_explicit(a, m) result(explicit)
    integer,  intent(in)                  :: m
    real(wp), intent(in), dimension(m,m)  :: a

    integer                 :: ii
    logical                 :: explicit
    logical, dimension(m,m) :: diag_upper

    ! allocate(diag_upper(m,m))
    diag_upper = .false.
    do ii = 1, m
      diag_upper(ii,ii:m) = .true.
    end do

    if ( sum(a, mask=diag_upper) == 0._wp ) then
      explicit = .true.
    else
      explicit = .false.
    end if

    return
  end function check_explicit

end module runge_kutta


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

! Riemann solver for the acoustics equations in 1D.

! waves:     2
! equations: 2

! Conserved quantities:
!       1 pressure
!       2 velocity

! On input, ql contains the state vector at the left edge of each cell
!           qr contains the state vector at the right edge of each cell

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

! Note that the i'th Riemann problem has left state qr(i-1,:)
!                                    and right state ql(i,:)
! From the basic clawpack routines, this routine is called with ql = qr

    implicit double precision (a-h,o-z)

    dimension wave(meqn, mwaves, 1-mbc:maxm+mbc)
    dimension    s(mwaves,1-mbc:maxm+mbc)
    dimension   ql(meqn, 1-mbc:maxm+mbc)
    dimension   qr(meqn, 1-mbc:maxm+mbc)
    dimension apdq(meqn, 1-mbc:maxm+mbc)
    dimension amdq(meqn, 1-mbc:maxm+mbc)

!     local arrays
!     ------------
    dimension delta(2)

!     # density, bulk modulus, and sound speed, and impedence of medium:
!     # (should be set in setprob.f)
    common /cparam/ rho,bulk,cc,zz

!     # split the jump in q at each interface into waves

!     # find a1 and a2, the coefficients of the 2 eigenvectors:
    do 20 i = 2-mbc, mx+mbc
        delta(1) = ql(1,i) - qr(1,i-1)
        delta(2) = ql(2,i) - qr(2,i-1)
        a1 = (-delta(1) + zz*delta(2)) / (2.d0*zz)
        a2 =  (delta(1) + zz*delta(2)) / (2.d0*zz)

    !        # Compute the waves.

        wave(1,1,i) = -a1*zz
        wave(2,1,i) = a1
        s(1,i) = -cc

        wave(1,2,i) = a2*zz
        wave(2,2,i) = a2
        s(2,i) = cc

    20 END DO

!     # compute the leftgoing and rightgoing flux differences:
!     # Note s(1,i) < 0   and   s(2,i) > 0.

    do 220 m=1,meqn
        do 220 i = 2-mbc, mx+mbc
            amdq(m,i) = s(1,i)*wave(m,1,i)
            apdq(m,i) = s(2,i)*wave(m,2,i)
    220 END DO

    return
    end subroutine rp1


!> \brief \b DLARTG generates a plane rotation with real cosine and real sine.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!  Definition:
!  ===========
!
!       SUBROUTINE DLARTG( F, G, C, S, R )
!
!       .. Scalar Arguments ..
!       REAL(wp)      C, F, G, R, S
!       ..
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DLARTG generates a plane rotation so that
!>
!>    [  C  S  ]  .  [ F ]  =  [ R ]
!>    [ -S  C  ]     [ G ]     [ 0 ]
!>
!> where C**2 + S**2 = 1.
!>
!> The mathematical formulas used for C and S are
!>    R = sign(F) * sqrt(F**2 + G**2)
!>    C = F / R
!>    S = G / R
!> Hence C >= 0. The algorithm used to compute these quantities
!> incorporates scaling to avoid overflow or underflow in computing the
!> square root of the sum of squares.
!>
!> This version is discontinuous in R at F = 0 but it returns the same
!> C and S as ZLARTG for complex inputs (F,0) and (G,0).
!>
!> This is a more accurate version of the BLAS1 routine DROTG,
!> with the following other differences:
!>    F and G are unchanged on return.
!>    If G=0, then C=1 and S=0.
!>    If F=0 and (G .ne. 0), then C=0 and S=sign(1,G) without doing any
!>       floating point operations (saves work in DBDSQR when
!>       there are zeros on the diagonal).
!>
!> If F exceeds G in magnitude, C will be positive.
!>
!> Below, wp=>dp stands for double precision from LA_CONSTANTS module.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] F
!> \verbatim
!>          F is REAL(wp)
!>          The first component of vector to be rotated.
!> \endverbatim
!>
!> \param[in] G
!> \verbatim
!>          G is REAL(wp)
!>          The second component of vector to be rotated.
!> \endverbatim
!>
!> \param[out] C
!> \verbatim
!>          C is REAL(wp)
!>          The cosine of the rotation.
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!>          S is REAL(wp)
!>          The sine of the rotation.
!> \endverbatim
!>
!> \param[out] R
!> \verbatim
!>          R is REAL(wp)
!>          The nonzero component of the rotated vector.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \date July 2016
!
!> \ingroup OTHERauxiliary
!
!> \par Contributors:
!  ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Anderson E. (2017)
!>  Algorithm 978: Safe Scaling in the Level 1 BLAS
!>  ACM Trans Math Softw 44:1--28
!>  https://doi.org/10.1145/3061665
!>
!> \endverbatim
!
subroutine DLARTG( f, g, c, s, r )
   use LA_CONSTANTS, &
   only: wp=>dp, zero=>dzero, half=>dhalf, one=>done, &
         rtmin=>drtmin, rtmax=>drtmax, safmin=>dsafmin, safmax=>dsafmax
!
!  -- LAPACK auxiliary routine (version 3.10.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     February 2021
!
!  .. Scalar Arguments ..
   real(wp) :: c, f, g, r, s
!  ..
!  .. Local Scalars ..
   real(wp) :: d, f1, fs, g1, gs, p, u, uu
!  ..
!  .. Intrinsic Functions ..
   intrinsic :: abs, sign, sqrt
!  ..
!  .. Executable Statements ..
!
   f1 = abs( f )
   g1 = abs( g )
   if( g == zero ) then
      c = one
      s = zero
      r = f
   else if( f == zero ) then
      c = zero
      s = sign( one, g )
      r = g1
   else if( f1 > rtmin .and. f1 < rtmax .and. &
            g1 > rtmin .and. g1 < rtmax ) then
      d = sqrt( f*f + g*g )
      p = one / d
      c = f1*p
      s = g*sign( p, f )
      r = sign( d, f )
   else
      u = min( safmax, max( safmin, f1, g1 ) )
      uu = one / u
      fs = f*uu
      gs = g*uu
      d = sqrt( fs*fs + gs*gs )
      p = one / d
      c = abs( fs )*p
      s = gs*sign( p, f )
      r = sign( d, f )*u
   end if
   return
end subroutine


program matrix_bounds
use, intrinsic :: iso_fortran_env, only : dp => REAL64
use matrix_mod
implicit none
integer, parameter :: rows = 3, cols = 2
integer :: i, j, k, istat
real(kind=dp), dimension(:, :), allocatable :: B, A, C
real(kind=dp) :: r

allocate(B(rows, cols))
allocate(A(rows, cols))
allocate(C(rows, rows))

do i = 1, rows
    do j = 1, cols
        call random_number(r)
        A(i, j) = r
        call random_number(r)
        B(i, j) = r
    end do
end do

do i = 1, rows
    do j = 1, rows
        C(i, j) = 0.0_dp
        do k = 1, cols
            C(i, j) = C(i, j) + A(i, k)*B(k, j)
        end do
    end do
end do

call print_matrix(C)
print '(A, F15.8)', 'sum = ', sum(C)

deallocate(A)
deallocate(B)
deallocate(C)

end program matrix_bounds


! Number F(46) is the highest allowed for integer(kind=4).  The next number,
! F(47) creates an integer overflow and produces a negative result.
!
! To test yourself, get the table of F(i) values from here:
!
!   https://oeis.org/A000045/b000045.txt
!
! Note: static arrays with save attribute inside routines are not allowed
! because they live in the stack frame.  Either allocate a dynamic array in the
! main program (you can also use a big enough static array) or use two extra
! variables and two extra indices with save attributes to store F(i - 2) and
! F(i - 1) values between the calls.
program fibonacci_memorized
    implicit none
    integer :: i
    integer, allocatable :: f(:) ! A dynamic array in the heap.

    print '(a)', "Enter index `i` for the Fibonacci sequence"
    read *, i
    ! Use value of -1 to mark F(i) that have not been computed yet.
    if (.not.allocated(f)) allocate(f(0:i), source=-1)

    print '(2(a, i0))', "F(", i, ") = ", fib_mem(i)
    if (allocated(f)) deallocate(f)
contains
    recursive function fib_mem(n) result(rslt)
        integer :: rslt
        integer, intent(in) :: n

        ! F(n) is not computed yet?
        if (f(n) == -1) then
            select case(n)
            case(0)
                f(0) = 0
            case(1)
                f(1) = 1
            case(2:)
                if (f(n - 2) == -1) f(n - 2) = fib_mem(n - 2)
                if (f(n - 1) == -1) f(n - 1) = fib_mem(n - 1)
                f(n) = f(n - 2) + f(n - 1)
            case default
                print '(a, i0)', "Wrong index n: ", n
                stop
            end select
        end if
        rslt = f(n)
        return
    end function fib_mem
end program fibonacci_memorized


      program param04

      parameter (y=5.)
      parameter (x=2*y+3.)

      print *, x+y

      end


SUBROUTINE trapzd(func,a,b,s,n)
INTEGER*4 n
REAL*8 a,b,s,func
EXTERNAL func
INTEGER*4 it,j
REAL*8 del,sum,tnm,x
if (n.eq.1) then
	s=0.5*(b-a)*(func(a)+func(b))
else
	it=2**(n-2)
	tnm=it
	del=(b-a)/tnm
	x=a+0.5*del
	sum=0.
	do j=1,it
		sum=sum+func(x)
		x=x+del
    enddo
	s=0.5*(s+(b-a)*sum/tnm)
endif
return
END


      SUBROUTINE midexp(funk,aa,bb,s,n)
      INTEGER n
      REAL aa,bb,s,funk
      EXTERNAL funk
      INTEGER it,j
      REAL ddel,del,sum,tnm,x,func,a,b
      func(x)=funk(-log(x))/x
      b=exp(-aa)
      a=0.
      if (n.eq.1) then
        s=(b-a)*func(0.5*(a+b))
      else
        it=3**(n-2)
        tnm=it
        del=(b-a)/(3.*tnm)
        ddel=del+del
        x=a+0.5*del
        sum=0.
        do 11 j=1,it
          sum=sum+func(x)
          x=x+ddel
          sum=sum+func(x)
          x=x+del
11      continue
        s=(s+(b-a)*sum/tnm)/3.
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/midexp.for


subroutine det_qjet(q, v, b)
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  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 version 3.
!
!  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.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: dis_qjet.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/flow2d3d/packages/kernel/src/compute_nearfar/dis_qjet.f90 $
!!--description-----------------------------------------------------------------
!
!    Function: Numerical integration to determine jet discharge
!
! Method used:
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
!
    use precision
    use mathconsts
!
! Global variables
!
    real(fp)   ::   b
    real(fp)   ::   q
    real(fp)   ::   v
!
! Local variables
!
    integer    ::   ib
    integer    ::   iphi
    real(fp)   ::   bstep
    real(fp)   ::   pstep
    real(fp)   ::   uuu
!
!! executable statements -------------------------------------------------------
!
    q  = 0.0_fp
    !
    pstep = pi / 100.0_fp
    bstep = b  / 100.0_fp
    !
    do iphi = 1, 100
       do ib = -100, 99
         uuu = v * exp(-1.0_fp*((real(ib,fp) + 0.5_fp)*bstep/b)**2)
         q   = q + uuu*bstep*pstep*abs((real(ib,fp)+0.5_fp)*bstep)
       enddo
    enddo
end subroutine det_qjet


! { dg-do run }
! PR34556 Rejects valid with bogus error message: parameter initalization
! Found using the Fortran Company Fortran 90 Test Suite (Lite),
! Version 1.4
! Test case modified by Jerry DeLisle  <jvdelisle@gcc.gnu.org to
! show correct results.
module splitprms
      integer, parameter  :: nplam = 3 ! # of plans to expand TABs
      integer, parameter  :: linem = 132 ! max. line length
      integer, parameter  :: ncntm = 39 ! max. # cont. lines
      integer, parameter, dimension (linem, nplam) :: nxttab =  &
      reshape ([[(6, i= 1, 2*linem) ], [(i, i= 1,linem)],    &
                max ([(i, i= 1,linem)], [(10*i, i= 1,linem)])],      &
               [linem, nplam ])
end module splitprms

program test
  use splitprms
  if (nxttab(1, 1) .ne. 6) call abort
  if (nxttab(1, nplam) .ne. 1) call abort
  if (nxttab(linem, 1) .ne. 6) call abort
  if (nxttab(linem, nplam) .ne. 132) call abort
end program test


c-------------------------------------------------------------
c PROGRAM   : QUADRATURE - TRAPEZOIDAL AND SIMPSONS RULES
c
c SUBJECT   : 640-364 COMPUTATIONAL PHYSICS
c NAME      : MICHAEL PAPASIMEON
c DATE      : 30/07/1997
c
c PURPOSE   : This program does a numerical integration
c           : between 0 and 1 for the function ln(1+x)/x
c           : using both the Trapezoidal and Simpsons
c           : rules for quadrature.
c-------------------------------------------------------------

      program main
            call all_trapezoidals
            call all_simpsons
      end

c-------------------------------------------------------------
c FUNCTION  : f
c PURPOSE   : Given a real number x, returns the result of
c           : evaluating ln(1+x)/x.
c           : Care is taken when x = 0, since this causes
c           : a division by zero error, and hence a value
c           : of 1 is returned in this case.
c-------------------------------------------------------------

      double precision function f(x)
      implicit none
      real*8 x
      if ( x .eq. 0.0d0 ) then
            f = 1.0
      else
            f = dlog(1+x)/x
      endif
      return
      end

c-------------------------------------------------------------
c SUBROUTINE : all_trapezoidals
c PURPOSE    : Calls the trapezoidal subroutine 6 each time
c            : with an increase in the number of divisions
c            : (increased by a factor of 10). The result
c            : is a table of the result of the quadrature
c            : including an output of the percentage error.
c-------------------------------------------------------------

      subroutine all_trapezoidals
      implicit none
      integer*4 n, i
      real*8 actual, pi, a, b

      a = 0.0d0
      b = 1.0d0
      pi = 4*atan(1.0d0)
      actual = (pi**2)/dfloat(12)

      write(*,*) '---------------------------------------------------'
      write(*,*) '                TRAPEZOIDAL RULE'
      write(*,*) '---------------------------------------------------'
      write(*,*) 'Lower Limit : a = ',a
      write(*,*) 'Upper Limit : b = ',b
      write(*,*) 'Actual Result = ',actual
      write(*,*) '---------------------------------------------------'
      write(*,*) '        n             h        Result         Error'
      write(*,*) '---------------------------------------------------'

      n = 10
      do 10 i = 0, 5, +1
            call trapezoidal(n,a,b,actual)
            n = n*10
10    continue
      write(*,*) '---------------------------------------------------'

      end

c-------------------------------------------------------------
c SUBROUTINE : trapezoidal
c PURPOSE    : Performs numerical quadrature using the
c            : trapezoidal rule for the function f
c            : between a and b and prints out the result
c            : for the number of divisions given as a
c            : parameter.
c-------------------------------------------------------------

      subroutine trapezoidal(n, a, b, answer)
      implicit none
      integer*4 n
      real*8 a, b, answer
      integer*4 i
      real*8 error, h, sum, x, f

      i = 0
      sum = 0.0d0
      x = 0.0d0
      h = (b-a)/dfloat(n)

      do 100 i = 1, (n-1), +1
        x = a + i*h
        sum = sum + 2.0d0*f(x)
100   continue

      sum = sum + f(a) + f(b)
      sum = (0.5d0)*h*sum
      error = abs(sum - answer)

      write(*,200) n, h, sum, error
200   format(i10, f14.10, f14.10, g14.6)

      end

c-------------------------------------------------------------
c SUBROUTINE : all_simpsons
c PURPOSE    : Calls the simpson subroutine 6 each time
c            : with an increase in the number of divisions
c            : (increased by a factor of 10). The result
c            : is a table of the result of the quadrature
c            : including an output of the percentage error.
c-------------------------------------------------------------

      subroutine all_simpsons
      implicit none
      integer*4 n, i
      real*8 actual, pi, a, b

      a = 0.0d0
      b = 1.0d0
      pi = 4*atan(1.0d0)
      actual = (pi**2)/dfloat(12)

      write(*,*) '---------------------------------------------------'
      write(*,*) '                SIMPSONS RULE'
      write(*,*) '---------------------------------------------------'
      write(*,*) 'Lower Limit : a = ',a
      write(*,*) 'Upper Limit : b = ',b
      write(*,*) 'Actual Result = ',actual
      write(*,*) '---------------------------------------------------'
      write(*,*) '        n             h        Result         Error'
      write(*,*) '---------------------------------------------------'

      n = 10
      do 10 i = 0, 5, +1
            call simpson(n,a,b,actual)
            n = n*10
10    continue
      write(*,*) '---------------------------------------------------'

      end

c-------------------------------------------------------------
c SUBROUTINE : simpson
c-------------------------------------------------------------

      subroutine simpson(n, a, b, answer)
      implicit none
      integer*4 n, i, factor
      real*8 a, b, answer
      real*8 error, h, sum, x, f

      i = 0
      factor = 4
      sum = 0.0d0
      x = 0.0d0
      h = (b-a)/dfloat(n)

      do 300 i = 1, (n-1), +1
        x = a+i*h
        if (factor .eq. 2) then
            sum = sum + 2*f(x)
            factor = 4
        else
            sum = sum + 4*f(x)
            factor = 2
        endif
300   continue
      sum = sum + f(a) + f(b)
      sum = (h*sum)/3.0d0
      error = dabs(sum - answer)

      write(*,400) n, h, sum, error
400   format(i10, f14.10, f14.10, g14.6)

      end


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

      SUBROUTINE splint(xa,ya,y2a,N,x,y,dt)
      IMPLICIT REAL*8 (A-H,K,O-Z)
      INTEGER, PARAMETER :: DP=kind(1D0)
      INTEGER :: N
      REAL(kind=DP), dimension(N) :: xa,y2a,ya
! ------------------------------------------------
!Given the arrays xa(1:n) and ya(1:n) of length n, which tabulate a function (with the xai’s in order), and given the array y2a(1:n), which is the output from spline above,and given a value of x, this routine returns a cubic-spline interpolated value y.
! -------------------------------------------------
      INTEGER :: k,khi,klo
      REAL(kind=DP) :: a,b,h,x1

! We will find the right place in the table by means of bisection. This is optimal if sequential calls to this routine are at random values of x. If sequential calls are in order, and closely spaced, one would do better to store previous values of klo and khi and test if they remain appropriate on the next call.

      klo=1
      khi=n
 1    IF (khi-klo.GT.1) THEN
         k=(khi+klo)/2
         IF(xa(k).GT.x)THEN
            khi=k
         ELSE
            klo=k
         END IF
         GO TO 1
      END IF

      h=xa(khi)-xa(klo)

      IF (x <= xa(1)) THEN
         y = ya(1)
         RETURN
      END IF
      IF (x >= xa(n)) THEN
         y = ya(n)
         RETURN
      END IF

!     The xa’s must be distinct.
! Cubic spline polynomial is now evaluated.
      a=(xa(khi)-x)/h
      b=(x-xa(klo))/h
      y=a*ya(klo)+b*ya(khi)+
     &     ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi))*(h**2)/6.

      RETURN
      END

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


program rand_test
! confirms random distribution of block types
use, intrinsic:: iso_fortran_env, only: dp=>real64
use shapes, only: gen_type
use random, only: rand_init, randint, std, mean

implicit none (type, external)

character(*), parameter :: types = 'ITLJSZOD'
integer,parameter :: Ntypes=len(types)
real, parameter :: rtol = 0.05
real :: ideal
character,allocatable :: b(:)
real, allocatable :: e(:)
integer, allocatable :: f(:), g(:)
integer :: i,n, c(Ntypes), u
character(16) :: buf

call rand_init(.false., .false.)

do i=1,10
  print*,randint(1,8)
enddo

N=1000000
call get_command_argument(1,buf,status=i)
if (i==0) read(buf,*) N

ideal = N/Ntypes

allocate(b(N), e(Ntypes), f(N), g(N))

do i = 1,N
  b(i) = gen_type()
enddo
! results
print '(/,A,I6)', 'ideal count:',int(ideal)
print '(A5,A16,A10)','Block','Count','Error %'
print '(A5,A16,A10)','-----','-----','-------'
do i=1,Ntypes
!do concurrent (i=1:Ntypes) ! even with ifort -parallel, still single core (with print commented)
  c(i) = count(b==types(i:i))
  e(i) = abs(c(i)-ideal) / ideal
  print '(A5,I16,F10.3)',types(i:i), c(i), e(i)*100
enddo

! randomness simple check -- sufficiently uniformly random
if (any(e > rtol)) then
  error stop 'non-uniform randomness posssible. Is N > 1000000?'
endif

! -----------

do i = 1,N
  f(i) = randint(-1073741823,  1073741823)
enddo

print '(/,A,I15,A,F15.3)','huge(int)',huge(0), 'huge(real)',huge(0.)
print *,'expected std, mean',real(huge(0), dp) / sqrt(12._dp), 0.
print *,'std, mean randint()',std(f), mean(f)
print *,'a few values',f(:6)

open(newunit=u, file='/dev/urandom', access="stream", form="unformatted", action="read", status="old", iostat=i)
if (i==0) then
  read(u) g
  close(u)

  print '(/,A)','/dev/urandom a few values...'
  print *,'std, mean /dev/urandom',std(g), mean(g)
endif

end program


!********************************************************************************
!   FORWERR_SIMPLE: Compare the forward error of FPML, FPML-Quad, and FPML-Comp
!   Author: Thomas R. Cameron, Penn State Erie The Behrend College
!   Last Modified: 31 July 2020
!********************************************************************************
program forwerr_simple
    use fpml, only : main
	use fpml_comp, only: main_comp
	use fpml_quad, only: qp, main_quad
    use mproutines
	implicit none
    ! testing variables
    integer                                     :: deg, it, j, startDegree, endDegree, itnum
    real(kind=dp), allocatable                  :: results(:,:)
    complex(kind=dp), allocatable               :: exact_roots(:)
    ! FPML variables
    integer, parameter                          :: itmax = 30
    integer, allocatable                        :: conv(:)
    real(kind=dp), allocatable                  :: berr(:), cond(:)
	real(kind=qp), allocatable					:: berr_quad(:), cond_quad(:)
    complex(kind=dp), allocatable               :: p(:), roots(:)
	complex(kind=qp), allocatable				:: p_quad(:), roots_quad(:)

    ! Test1: Chebyshev Polynomial
    startDegree = 5
    endDegree = 80
    itnum = 32
    open(unit=1,file="data_files/forwerr_cheby.dat")
    write(1,'(A)') 'Degree, FPML-err, FPML-Quad-err, FPML-Comp-err'
    allocate(results(itnum,3))
    deg = startDegree
    do while(deg<=endDegree)
        write(1,'(I10,A)', advance='no') deg, ', '
		! allocate
        allocate(roots(deg), berr(deg), cond(deg), conv(deg))
		allocate(p_quad(deg+1), roots_quad(deg), berr_quad(deg), cond_quad(deg))
        ! polynomial
        call make_poly(1, deg, exact_roots, p)
        do it=1,itnum
            ! FPML, No Polish
            call main(p, deg, roots, berr, cond, conv, itmax)
            results(it,1) = max_rel_err(roots, exact_roots, deg)
			! FPML, Quad
			p_quad = p
            call main_quad(p_quad, deg, roots_quad, berr_quad, cond_quad, conv, itmax)
			roots = roots_quad
			results(it,2) = max_rel_err(roots, exact_roots, deg)
            ! FPML, Compensated Laguerre Polish
            call main_comp(p, deg, roots, itmax)
            results(it,3) = max_rel_err(roots, exact_roots, deg)
        end do
		! deallocate
        deallocate(p, exact_roots, roots, berr, cond, conv)
		deallocate(p_quad, roots_quad, berr_quad, cond_quad)
        ! write results to file
        write(1,'(ES15.2,A)', advance='no') sum(results(1:itnum,1))/itnum, ','
        write(1,'(ES15.2,A)', advance='no') sum(results(1:itnum,2))/itnum, ','
        write(1,'(ES15.2)') sum(results(1:itnum,3))/itnum
        ! update deg
        deg = deg + 1
    end do
    ! deallocate results and close file
    deallocate(results)
    close(1)

    ! Test2: Prescribed Roots of Varying Scale - 3
    startDegree = 5
    endDegree = 20
    itnum = 32
    open(unit=1,file="data_files/forwerr_presc.dat")
    write(1,'(A)') 'Degree, FPML-err, FPML-Quad-err, FPML-Comp-err'
    allocate(results(itnum,3))
    deg = startDegree
    do while(deg<=endDegree)
        write(1,'(I10,A)', advance='no') deg, ', '
		! allocate
        allocate(roots(deg), berr(deg), cond(deg), conv(deg))
		allocate(p_quad(deg+1), roots_quad(deg), berr_quad(deg), cond_quad(deg))
        ! polynomial
        call make_poly(2, deg, exact_roots, p)
        do it=1,itnum
            ! FPML, No Polish
            call main(p, deg, roots, berr, cond, conv, itmax)
            results(it,1) = max_rel_err(roots, exact_roots, deg)
			! FPML, Quad
			p_quad = p
            call main_quad(p_quad, deg, roots_quad, berr_quad, cond_quad, conv, itmax)
			roots = roots_quad
			results(it,2) = max_rel_err(roots, exact_roots, deg)
            ! FPML, Compensated Laguerre Polish
            call main_comp(p, deg, roots, itmax)
            results(it,3) = max_rel_err(roots, exact_roots, deg)
        end do
		! deallocate
        deallocate(p, exact_roots, roots, berr, cond, conv)
		deallocate(p_quad, roots_quad, berr_quad, cond_quad)
        ! write results to file
        write(1,'(ES15.2,A)', advance='no') sum(results(1:itnum,1))/itnum, ','
        write(1,'(ES15.2,A)', advance='no') sum(results(1:itnum,2))/itnum, ','
        write(1,'(ES15.2)') sum(results(1:itnum,3))/itnum
        ! update deg
        deg = deg + 1
    end do
    ! deallocate results and close file
    deallocate(results)
    close(1)

    ! Test3: Small Imaginary Part
    startDegree = 5
    endDegree = 25
    itnum = 32
    open(unit=1,file="data_files/forwerr_smallimag.dat")
    write(1,'(A)') 'Degree, FPML-err, FPML-Quad-err, FPML-Comp-err'
    allocate(results(itnum,3))
    deg = startDegree
    do while(deg<=endDegree)
        write(1,'(I10,A)', advance='no') deg, ', '
		! allocate
        allocate(roots(deg), berr(deg), cond(deg), conv(deg))
		allocate(p_quad(deg+1), roots_quad(deg), berr_quad(deg), cond_quad(deg))
        ! polynomial
        call make_poly(3, deg, exact_roots, p)
        do it=1,itnum
            ! FPML, No Polish
            call main(p, deg, roots, berr, cond, conv, itmax)
            results(it,1) = max_rel_err(roots, exact_roots, deg)
			! FPML, Quad
			p_quad = p
            call main_quad(p_quad, deg, roots_quad, berr_quad, cond_quad, conv, itmax)
			roots = roots_quad
			results(it,2) = max_rel_err(roots, exact_roots, deg)
            ! FPML, Compensated Laguerre Polish
            call main_comp(p, deg, roots, itmax)
            results(it,3) = max_rel_err(roots, exact_roots, deg)
        end do
		! deallocate
        deallocate(p, exact_roots, roots, berr, cond, conv)
		deallocate(p_quad, roots_quad, berr_quad, cond_quad)
        ! write results to file
        write(1,'(ES15.2,A)', advance='no') sum(results(1:itnum,1))/itnum, ','
        write(1,'(ES15.2,A)', advance='no') sum(results(1:itnum,2))/itnum, ','
        write(1,'(ES15.2)') sum(results(1:itnum,3))/itnum
        ! update deg
        deg = deg + 1
    end do
    ! deallocate results and close file
    deallocate(results)
    close(1)

    ! Test4: Wilkinson Polynomial
    startDegree = 5
    endDegree = 20
    itnum = 32
    open(unit=1,file="data_files/forwerr_wilk.dat")
    write(1,'(A)') 'Degree, FPML-err, FPML-Quad-err, FPML-Comp-err'
    allocate(results(itnum,3))
    deg = startDegree
    do while(deg<=endDegree)
        write(1,'(I10,A)', advance='no') deg, ', '
		! allocate
        allocate(roots(deg), berr(deg), cond(deg), conv(deg))
		allocate(p_quad(deg+1), roots_quad(deg), berr_quad(deg), cond_quad(deg))
        ! polynomial
        call make_poly(4, deg, exact_roots, p)
        do it=1,itnum
            ! FPML, No Polish
            call main(p, deg, roots, berr, cond, conv, itmax)
            results(it,1) = max_rel_err(roots, exact_roots, deg)
			! FPML, Quad
			p_quad = p
            call main_quad(p_quad, deg, roots_quad, berr_quad, cond_quad, conv, itmax)
			roots = roots_quad
			results(it,2) = max_rel_err(roots, exact_roots, deg)
            ! FPML, Compensated Laguerre Polish
            call main_comp(p, deg, roots, itmax)
            results(it,3) = max_rel_err(roots, exact_roots, deg)
        end do
		! deallocate
        deallocate(p, exact_roots, roots, berr, cond, conv)
		deallocate(p_quad, roots_quad, berr_quad, cond_quad)
        ! write results to file
        write(1,'(ES15.2,A)', advance='no') sum(results(1:itnum,1))/itnum, ','
        write(1,'(ES15.2,A)', advance='no') sum(results(1:itnum,2))/itnum, ','
        write(1,'(ES15.2)') sum(results(1:itnum,3))/itnum
        ! update deg
        deg = deg + 1
    end do
    ! deallocate results and close file
    deallocate(results)
    close(1)

contains

    !************************************************
    !                       make_poly               *
    !************************************************
    ! Make special polynomial corresponding to
    ! poly_num and deg > 1.
    !************************************************
    subroutine make_poly(poly_num, deg, exact_roots, p)
        implicit none
        ! argument variables
        integer, intent(in)                         :: poly_num, deg
        complex(kind=dp), allocatable, intent(out)  :: exact_roots(:), p(:)
        ! local variables
        integer                                     :: j
        real(kind=dp)                               :: tmp, a(deg+1), b(deg+1), c(deg+1)
        real(kind=dp), parameter                    :: pi = 3.1415926535897932385E0_dp

        select case (poly_num)
            case(1)
            ! Chebyshev Polynomial
            allocate(exact_roots(deg), p(deg+1))
            do j=1,deg
                tmp = cos(pi*(2.0_dp*j-1.0_dp)/(2.0_dp*deg))
                if(abs(tmp)<mu) tmp = 0.0_dp
                exact_roots(j) = cmplx(tmp,0,kind=dp)
            end do
            a = 0.0_dp; a(1) = 1.0_dp
            b = 0.0_dp; b(2) = 1.0_dp
            do j=2,deg
                c = 0.0_dp
                c(2:deg+1) = b(1:deg)
                p = cmplx(2.0_dp*c - a,0,kind=dp)
                a = b
                b = real(p,kind=dp)
            end do
            case(2)
            ! Prescribed Roots of Varying scale
            allocate(exact_roots(deg), p(deg+1))
            if(mod(deg,2)==0) then
                exact_roots = (/ (cmplx(2.0_dp**(-deg/2+j)-3.0_dp,0,kind=dp), j=0,deg-1)/)
            else
                exact_roots = (/ (cmplx(2.0_dp**(-(deg-1)/2+j)-3.0_dp,0,kind=dp), j=0,deg-1)/)
            end if
			p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(3)
            ! Small Imaginary Part
            allocate(exact_roots(deg), p(deg+1))
            do j=1,deg
                if(mod(j,2)==0) then
                    exact_roots(j) = cmplx(j,-10*mu,kind=dp)
                else
                    exact_roots(j) = cmplx(j,10*mu,kind=dp)
                end if
            end do
			p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(4)
            ! Wilkinson Polynomial
            allocate(exact_roots(deg), p(deg+1))
            exact_roots = (/ (cmplx(j,0,kind=dp), j=1,deg)/)
			p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
        end select
    end subroutine make_poly
    !************************************************
    !                       max_rel_err             *
    !************************************************
    ! Compute maximum relative error between roots
    ! and exact roots.
    !************************************************
    function max_rel_err(roots, exact_roots, deg) result(res)
        implicit none
        ! argument variables
        integer, intent(in)             :: deg
        complex(kind=dp), intent(in)    :: exact_roots(:), roots(:)
        ! local variables
        logical                         :: m(deg)
        integer                         :: i, j, k
        real(kind=dp)                   :: delta, err, res, relerr, rmax
        ! intrinsic procedures
        intrinsic                       :: abs, max, huge

        ! initialize
        m = .True.
        rmax = huge(1.0_dp)
        res = mu
        ! main loop
        do i=1,deg
            ! find corresponding exact root (yet to be matched)
            err = rmax
            do j=1,deg
                if(m(j)) then
                    delta = abs(exact_roots(j) - roots(i))
                    if(delta < err) then
                        err = delta
                        k = j
                    end if
                end if
            end do
            ! mark corresponding root as matched
            m(k) = .False.
            ! calculate relative error on this root and update max
            ! zero roots give unhelpful relative errors, so revert to absolute error
            if(abs(roots(i))<mu .or. abs(exact_roots(k))<mu) then
                relerr = err
            else
                relerr = err/abs(exact_roots(k))
            end if
            res = max(relerr, res)
        end do
        res = max(res,mu)
    end function max_rel_err
end program forwerr_simple


! { dg-do run }
! Modified program from http://groups.google.com/group/\
! comp.lang.fortran/browse_frm/thread/423e4392dc965ab7#
!
module myoperator
   contains
      function dadd(arg1,arg2)
         integer ::dadd(2)
         integer, intent(in) :: arg1(2), arg2(2)
         dadd(1)=arg1(1)+arg2(1)
         dadd(2)=arg1(2)+arg2(2)
      end function dadd
end module myoperator

program test_interface

   use myoperator

   implicit none

   interface operator (.myadd.)
      module procedure dadd
   end interface

   integer input1(2), input2(2), mysum(2)

   input1 = (/0,1/)
   input2 = (/3,3/)
   mysum = input1 .myadd. input2
   if (mysum(1) /= 3 .and. mysum(2) /= 4) STOP 1

   call test_sub(input1, input2)

end program test_interface

subroutine test_sub(input1, input2)

   use myoperator

   implicit none

   interface operator (.myadd.)
      module procedure dadd
   end interface

   integer, intent(in) :: input1(2), input2(2)
   integer mysum(2)

   mysum = input1 .myadd. input2
   if (mysum(1) /= 3 .and. mysum(2) /= 4) STOP 2

end subroutine test_sub


C NCLFORTSTART
      SUBROUTINE DEXPTAPER(N0,R,S,NLAT,JER)
      IMPLICIT NONE
c                                input
      INTEGER R,NLAT,JER
      DOUBLE PRECISION N0
c                                output [ALLOCATE IN INTERFACE]
      DOUBLE PRECISION S(NLAT)
C NCLEND

c NCL: wgt = exp_taper (n0, r)

      INTEGER N
      DOUBLE PRECISION CON

      JER = 0
      IF (R.LE.0) THEN
          JER = 1
          PRINT *,'DEXPTAPER: r must be > 0:  r=',R
      END IF
      IF (N0.LE.0.D0) THEN
          JER = 10
          PRINT *,'DEXPTAPER: no must be > 0:  n0=',N0
      END IF
      IF (JER.NE.0) RETURN
c
c equation 9
c
      CON = N0* (N0+1.D0)
      DO N = 1,NLAT
          S(N) = EXP(- (N* (N+1)/CON)**R)
      END DO
c now wgt the coef by the wgts
c
      RETURN
      END

C NCLFORTSTART
      SUBROUTINE DEXPTAPERSH(MB,NB,AB,BB,N0,R,JER)
      IMPLICIT NONE
      INTEGER MB,NB,R,JER
      DOUBLE PRECISION AB(MB,NB),BB(MB,NB),N0
C NCLEND

c NCL: exp_tapersh (a,b, n0, r)
c      ab = exp_tapershC (ab, n0, r)

c     perform an exponential taper on the spherical harmonic coef

      INTEGER M,N,KER
      DOUBLE PRECISION S(2*NB)

      JER = 0
      IF ((N0+2).GT.NB) THEN
          JER = 8
          WRITE (*,FMT=
     +'(''SUB DEXPTAPERSH: N0 too large: ''
     +   ,''N0='',f8.0,3x,''iwave,nb='',2i5)') N0,R,NB
      ELSE IF (NB.NE.MB) THEN
          JER = 9
          WRITE (*,FMT=
     +'(''SUB DEXPTAPERSH: nb .ne. mb: ''
     +   ,''nb,mb='',2i5)') NB,MB
      END IF
      IF (JER.NE.0) RETURN
c equation 9
c
      CALL DEXPTAPER(N0,R,S,NB,KER)
c now wgt the coef by the wgts
c
      DO N = 1,NB
          DO M = 1,N
              AB(M,N) = AB(M,N)*S(N)
              BB(M,N) = BB(M,N)*S(N)
          END DO
      END DO

      RETURN
      END


PROGRAM whole_array

  IMPLICIT NONE
  REAL, PARAMETER :: pi = 3.14159
  REAL, DIMENSION(10) :: a, b
  INTEGER :: i

  !Set all elements of a to be pi
  a = pi
  !Scale a so that the elements go pi/2, pi, 3pi/2 etc
  DO i = 1, SIZE(a)
    a(i) = a(i) * REAL(i)/2.0
  END DO
  b = SIN(a)
  PRINT *, b

END PROGRAM whole_array


c---------------------------------------------------------------------
c---------------------------------------------------------------------
       pure extrinsic (hpf_local)
     >  subroutine exact_solution(xi,eta,zeta,dtemp)
       include 'cnst.h'

       double precision, intent(in) ::  xi, eta, zeta
       double precision, intent(out), dimension(:) :: dtemp
c---------------------------------------------------------------------
c---------------------------------------------------------------------

c---------------------------------------------------------------------
c     this function returns the exact solution at point xi, eta, zeta
c---------------------------------------------------------------------

      integer m

      do m = 1, 5
         dtemp(m) =  ce(m,1) +
     >     xi*(ce(m,2) + xi*(ce(m,5) + xi*(ce(m,8) + xi*ce(m,11)))) +
     >     eta*(ce(m,3) + eta*(ce(m,6) + eta*(ce(m,9) + eta*ce(m,12))))+
     >     zeta*(ce(m,4) + zeta*(ce(m,7) + zeta*(ce(m,10) +
     >     zeta*ce(m,13))))
      enddo

      return
      end


! Program to test FORALL construct
program forall_1

   call actual_variable ()
   call negative_stride ()
   call forall_index ()

contains
   subroutine actual_variable ()
      integer:: x = -1
      integer a(3,4)
      j = 100

      ! Actual variable 'x' and 'j' used as FORALL index
      forall (x = 1:3, j = 1:4)
         a (x,j) = j
      end forall
      if (any (a.ne.reshape ((/1,1,1,2,2,2,3,3,3,4,4,4/), (/3,4/)))) call abort
      if ((x.ne.-1).or.(j.ne.100)) call abort

      call actual_variable_2 (x, j, a)
   end subroutine

   subroutine actual_variable_2(x, j, a)
      integer x,j,x1,j1
      integer a(3,4), b(3,4)

      ! Actual variable 'x' and 'j' used as FORALL index.
      forall (x=3:1:-1, j=4:1:-1)
         a(x,j) = j
         b(x,j) = j
      end forall

      if (any (a.ne.reshape ((/1,1,1,2,2,2,3,3,3,4,4,4/), (/3,4/)))) call abort
      if (any (b.ne.reshape ((/1,1,1,2,2,2,3,3,3,4,4,4/), (/3,4/)))) call abort
      if ((x.ne.-1).or.(j.ne.100)) call abort
   end subroutine

   subroutine negative_stride ()
      integer a(3,4)
      integer x, j

      ! FORALL with negative stride
      forall (x = 3:1:-1, j = 4:1:-1)
         a(x,j) = j + x
      end forall
      if (any (a.ne.reshape ((/2,3,4,3,4,5,4,5,6,5,6,7/), (/3,4/)))) call abort
   end subroutine

   subroutine forall_index
      integer a(32,32)

      ! FORALL with arbitrary number indexes
      forall (i1=1:2,i2=1:2,i3=1:2,i4=1:2,i5=1:2,i6=1:2,i7=1:2,i8=1:2,i9=1:2,&
              i10=1:2)
         a(i1+2*i3+4*i5+8*i7+16*i9-30,i2+2*i4+4*i6+8*i8+16*i10-30) = 1
      end forall
      if ((a(5,5).ne.1).or. (a(32,32).ne.1)) call abort
   end subroutine

end


! { dg-do run }
!
! PR 60777: [F03] RECURSIVE function rejected in specification expression
!
! Contributed by Vladimir Fuka <vladimir.fuka@gmail.com>

module recur
  implicit none
contains

  pure recursive function f(n) result(answer)
    integer, intent(in) :: n
    integer             :: answer
    if (n<2) then
      answer = 1
    else
      answer = f(n-1)*n
    end if
  end function

  pure function usef(n)
    integer,intent(in) :: n
    character(f(n))    :: usef
    usef = repeat('*',f(n))
  end function
end module

program testspecexpr
  use recur
  implicit none
  if (usef(1) /= '*')      STOP 1
  if (usef(2) /= '**')     STOP 2
  if (usef(3) /= '******') STOP 3
end


program euler
  integer sum, i

  sum = 0

  do i = 1, 999
    if ((mod(i, 3) == 0) .or. (mod(i, 5) == 0)) then
      sum = sum + i
    endif
  end do

  write(*, '(i6)') sum
end program euler


      DOUBLE PRECISION FUNCTION QUAGAM(F,PARA)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  QUANTILE FUNCTION OF THE GAMMA DISTRIBUTION
C
C  OTHER ROUTINES USED: DERF,DLGAMA,GAMIND,QUASTN
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION PARA(2)
      DATA ZERO/0D0/,P01/0.01D0/,ONE/1D0/,NINE/9D0/
C
C         EPS,MAXIT CONTROL THE TEST FOR CONVERGENCE OF N-R ITERATION
C
      DATA EPS/1D-10/,MAXIT/30/
C
      QUAGAM=ZERO
      ALPHA=PARA(1)
      BETA=PARA(2)
      IF(ALPHA.LE.ZERO.OR.BETA.LE.ZERO)GOTO 1000
      IF(F.LT.ZERO.OR.F.GE.ONE)GOTO 1010
      IF(F.EQ.ZERO)RETURN
      AM1=ALPHA-ONE
      IF(AM1.NE.ZERO)GOTO 10
C
C         CASE ALPHA.EQ.1 - GAMMA IS EXPONENTIAL
C
      QUAGAM=(-DLOG(ONE-F))*BETA
      RETURN
C
C         INITIAL ESTIMATE OF ROOT OF EQUATION GAMIND(X)=F:
C         - IF ALPHA.GT.1, USE WILSON-HILFERTY APPROXIMATION IF IT'S
C           POSITIVE AND NOT TOO CLOSE TO ZERO;
C         - IF ALPHA.LT.1, OR IF W-H APPROX. ISN'T POSITIVE ENOUGH,
C           USE THE SMALL-X APPROXIMATION OF IGNORING THE EXP(-T) TERM
C           IN THE INTEGRAL DEFINING GAMIND(X)
C
   10 DLOGG=DLGAMA(ALPHA)
      IF(AM1.LE.ZERO)GOTO 20
      ROOT=ALPHA*(ONE-ONE/(NINE*ALPHA)+QUASTN(F)/DSQRT(NINE*ALPHA))**3
      IF(ROOT.GT.P01*ALPHA)GOTO 30
   20 ROOT=DEXP((DLOG(ALPHA*F)+DLOGG)/ALPHA)
   30 CONTINUE
C
C         REFINE INITIAL ESTIMATE BY NEWTON-RAPHSON ITERATION
C
      DO 40 IT=1,MAXIT
      FUNC=GAMIND(ROOT,ALPHA,DLOGG)-F
      RINC=FUNC*DEXP(DLOGG+ROOT-AM1*DLOG(ROOT))
      ROOT=ROOT-RINC
      IF(DABS(FUNC).LE.EPS)GOTO 50
   40 CONTINUE
      WRITE(6,7020)
C
C         SCALE SOLUTION
C
   50 QUAGAM=ROOT*BETA
      RETURN
C
 1000 WRITE(6,7000)
      RETURN
 1010 WRITE(6,7010)
      RETURN
C
 7000 FORMAT(' *** ERROR *** ROUTINE QUAGAM : PARAMETERS INVALID')
 7010 FORMAT(' *** ERROR *** ROUTINE QUAGAM :',
     *  ' ARGUMENT OF FUNCTION INVALID')
 7020 FORMAT(' ** WARNING ** ROUTINE QUAGAM :',
     *  ' ITERATION HAS NOT CONVERGED. RESULT MAY BE UNRELIABLE')
      END


! Truong Dang
! 01-11-2016
program Laplace_2D
    implicit none
    interface
       function functionf2D(x,y,k)
          real(8)::functionf2D,y,x
          integer(4)::k
       end function functionf2D

       function exact_solution2D(x,y,k)
          real(8)::exact_solution2D,y,x
          integer(4)::k
       end function exact_solution2D
    end interface

    integer(4)::N,k1,j,i,t
    real(8)::aa,bb
    real(8)::h,k
    real(8),dimension(4)::M
    real(8),dimension(:),allocatable::x,xcp,y,ycp,F,u
    real(8),dimension(:,:),allocatable::B,A,C,D,B_temp,B_temp_inv
    real(8),dimension(:,:),allocatable::u_dis,u_exact

    real(8),dimension(4)::norm_l2,norm_l1

    real(8)::ai,bi,cj,dj,sij
    integer(4)::i1,i2

    N=2
    k1=3

    do j=1,4
       aa=0.0d0
       bb=1.0d0
       N=N*2
       allocate(x(1:N))
       allocate(xcp(1:N+1))
       allocate(y(1:N))
       allocate(ycp(1:N+1))
       allocate(B(1:(N-1)*(N-1),1:(N-1)*(N-1)))
       allocate(B_temp(1:(N-1)*(N-1),1:(N-1)*(N-1)))
       allocate(B_temp_inv(1:(N-1)*(N-1),1:(N-1)*(N-1)))
       allocate(A(1:N-1,1:N-1))
       allocate(C(1:N-1,1:N-1))
       allocate(D(1:N-1,1:N-1))
       allocate(F(1:(N-1)*(N-1)))
       allocate(u(1:(N-1)*(N-1)))
       allocate(u_dis(1:N+1,1:N+1))
       allocate(u_exact(1:N+1,1:N+1))

       M(j)=N

    !%%Make mesh points x(i+1/2)
    h=1.0/(N-1)
    x(1)=aa
    do i=2,N-1
        x(i)=(i-1)*h + x(1)
    enddo
    x(N)=bb

    !%%Make control points xcp(i)
    xcp=0.0d0
    xcp(1)=x(1)
    do i=2,N+1
        if (i==N+1) then
            xcp(i)=x(i-1)
        else
            xcp(i)=(x(i)+x(i-1))/2.0d0;
        endif
    enddo

    !%%Make mesh points y(i+1/2) i=0,1,...,N
    k=1.0d0/(N-1)
    y(1)=aa
    do i=2,N-1
        y(i)=(i-1)*k + y(1)
    enddo
    y(N)=bb

    !%%Make control points ycp(i) i=0,1,...,N+1
    ycp=0.0d0
    ycp(1)=y(1)
    do i=2,N+1
        if (i==N+1) then
            ycp(i)=y(i-1)
        else
            ycp(i)=(y(i)+y(i-1))/2.0d0
        endif
    enddo
    !%%

    B=0.0d0

    !%%
    ai=-1.0d0/h**2
    bi=-1.0d0/h**2
    cj=-1.0d0/k**2
    dj=-1.0d0/k**2
    sij=(ai+bi+cj+dj)
    !%%
    A=0.0d0
    do i=1,N-1
        if(i==1) then
            A(i,i)=sij
            A(i,i+1)=-bi
            elseif(i==N-1)then
                A(i,i)=sij
                A(i,i-1)=-ai
            else
                A(i,i)=sij
                A(i,i-1)=-ai
                A(i,i+1)=-bi
            endif

    enddo
    !%%

        C=0.0d0
        do i=1,N-1
            C(i,i)=-cj
        enddo

    !%%

        D=0.0d0
        do i=1,N-1
            D(i,i)=-dj
        enddo

    !%%

    do i=1,N-1
        if(i==1)then
            B((i-1)*(N-1)+1:i*(N-1),(i-1)*(N-1)+1:i*(N-1))=-A
            B((i-1)*(N-1)+1:i*(N-1),i*(N-1)+1:(i+1)*(N-1))=-D
        elseif(i==N-1)then
                B((i-1)*(N-1)+1:i*(N-1),(i-1)*(N-1)+1:i*(N-1))=-A
                B((i-1)*(N-1)+1:i*(N-1),(i-2)*(N-1)+1:(i-1)*(N-1))=-C
            else
                B((i-1)*(N-1)+1:i*(N-1),(i-1)*(N-1)+1:i*(N-1))=-A
                B((i-1)*(N-1)+1:i*(N-1),i*(N-1)+1:(i+1)*(N-1))=-D
                B((i-1)*(N-1)+1:i*(N-1),(i-2)*(N-1)+1:(i-1)*(N-1))=-C

        endif
    enddo
    !%A=(1/h^2)*A;
    F=0.0d0
    do i1=1,N-1
        do i2=1,N-1
            F((i1-1)*(N-1)+i2)=functionf2D(xcp(i2),ycp(i1),k1)
        enddo
    enddo
    !u=B\F;
    B_temp = B
    call gauss_2(B,F,u,(N-1)*(N-1))
    call matinv(B_temp,(N-1)*(N-1),B_temp_inv)
    !print*,B_temp_inv

    !do i1=1,(N-1)*(N-1)
    !        u(i1) = (1.0D0/B(i1,i1))*(F(i1) &
    !        -dot_product(B(i1,1:(N-1)*(N-1)),u)+B(i1,i1) &
    !        *u(i1))
    !enddo

    u_dis=0.0d0
    do i1=1,N-1
        do i2=1,N-1
            u_dis(i1+1,i2+1)=u((i1-1)*(N-1)+i2)
        enddo
    enddo

    open(unit=1,file='u_dis')
    do i1=1,N+1
        do i2=1,N+1
            write(1,*),xcp(i1),ycp(i2),u_dis(i1,i2)
        enddo
        write(1,*),''
    enddo
    close(unit=1)

    u_exact=0.0d0
    do i1=1,N+1
        do i2=1,N+1
            u_exact(i1,i2)=exact_solution2D(xcp(i2),ycp(i1),k1)
        enddo
    enddo

    open(unit=2,file='u_exact')
    do i1=1,N+1
        do i2=1,N+1
            write(2,*),xcp(i1),ycp(i2),u_exact(i1,i2)
        enddo
        write(2,*),''
    enddo
    close(unit=2)
    !figure
    !surf(xcp,ycp,u_dis)
    !title('u discrete', 'FontWeight','bold')
    !if(k1==2)
    !    zlim([0 0.08])
    !else
    !    zlim([0 0.025])
    !end

    !figure
    !surf(xcp,ycp,u_exact)
    !title('u exact', 'FontWeight','bold')
    !%% Odd indices figures: u discrete
    !%% Even indices figures: u exact

    !%%
    norm_l2(j)=0.0d0
    norm_l1(j)=0.0d0

    do i=1,N+1
        do t=1,N+1
        norm_l2(j)=norm_l2(j)+(u_dis(i,t)-u_exact(i,t))**2*h*k
        norm_l1(j)=norm_l1(j)+abs(u_dis(i,t)-u_exact(i,t))*h*k
        enddo
    enddo
    norm_l2(j)=sqrt(norm_l2(j))
    print*,'Mesh size:',N,'x',N
    print*,'L2 norm = ',norm_l2(j)
    print*,'L1 norm = ',norm_l1(j)

!    %%
!    %%
!    norm_h1(j)=0;
!    %norm_h1(j)=norm_h1(j)+(((u_dis(1)-u_exact(1))))^2;
!     for i=1:N
!         for t=1:N
!             if (i==1)&&(t==1)
!                 norm_h1(j)=norm_h1(j)+4*(((u_dis(i,t)-u_exact(i,t))))^2;
!             else
!                 norm_h1(j)=norm_h1(j)+(abs(u_dis(i+1,t)-u_exact(i+1,t))-abs(u_dis(i,t)-u_exact(i,t)))^2+(abs(u_dis(i,t+1)-u_exact(i,t+1))-abs(u_dis(i,t)-u_exact(i,t)))^2;
!             end
!         end
!     end
!     %norm_h1(j)=norm_h1(j)+(((u_dis(N)-u_exact(N))-(u_dis(N-1)-u_exact(N-1))))^2;
!     norm_h1(j)=(norm_h1(j))^(1/2);
!
!    %%

!figure
!%plot( log(M), -log(norm_l2), 'red', log(M), 2*log(M),'black', log(M), -log(norm_h1), 'cyan', log(M), (1/2)*log(M), 'green')
!%ylim([0 20])
!%legend('|| ||_{L^2}','2*Log(N)','|| ||_{H^1_0}','(1/2)*Log(N)')
!%legend('Location','northwest')
!plot( log(M), -log(norm_l2))
!hold on
!plot( log(M), 2*log(M),'r')
!xlabel("Log(N)")
!ylabel("-Log(err)")
    deallocate(x)
    deallocate(xcp)
    deallocate(y)
    deallocate(ycp)
    deallocate(B)
    deallocate(B_temp)
    deallocate(B_temp_inv)
    deallocate(A)
    deallocate(C)
    deallocate(D)
    deallocate(F)
    deallocate(u)
    deallocate(u_dis)
    deallocate(u_exact)
enddo

open(unit=3,file='L2 norm')
do j=1,4
    write(3,*),log(M(j)),log(norm_l2(j))
enddo
close(unit=3)

open(unit=4,file='L1 norm')
do j=1,4
    write(4,*),log(M(j)),log(norm_l1(j))
enddo
close(unit=4)

end program

function functionf2D(x,y,k)
   implicit none
   real(8)::functionf2D,y,x
   integer(4)::k

if (k==1) then
    functionf2D =2
endif

if (k==2) then
    functionf2D =2*y*(1-y)+2*x*(1-x)
endif

if (k==3) then
    functionf2D =2*x**2*(2*y - 2)*(x - 1) + 2*x**2*y*(x - 1) + 4*x*y*(y - 1)**2 + 2*y*(x - 1)*(y - 1)**2
endif

!if (k==4)
!    f=2*y^2*(2*x - 2)*(y - 1) + 4*x*y*(x - 1)^2 + 2*x*y^2*(y - 1) + 2*x*(x - 1)^2*(y - 1);
!end

if (k==5) then
    functionf2D =0.0d0
endif

end function functionf2D

function exact_solution2D(x,y,k)
    implicit none
    real(8)::exact_solution2D,y,x
    integer(4)::k
if (k==1) then
    exact_solution2D =x*(1-x)
endif
!% Truong added 1-11-2016
!% Neu truyen k=1, ham chi phu thuoc x nen nghiem xap xi ra sai

if(k==2)then
    exact_solution2D=x*(1-x)*y*(1-y)
endif

if (k==3) then
    exact_solution2D =x**2*(1-x)*y*(1-y)**2
endif

!if (k==4) then
!    u_ex=x*(1-x)^2*y^2*(1-y)
!endif

if (k==5) then
    exact_solution2D = sin(x)*exp(y)
endif
end function exact_solution2D


      program vanderwaal
      implicit none
            real :: P, V, a ,b, T, temp1, temp2, R
            T = 273
            a=5
            R=8.314
            b=6

            PRINT *, 'Enter value of V'
            READ (*,*) V
            temp1 = R*T
            temp1 = temp1/(V-b)
            temp2 = a/(V*V)
            P = temp1 - temp2
            PRINT *,'The value of P is ', P
      end program vanderwaal


C++-------------------------------------------------------------------------
C CALCUL DE LA PRECESSION
C From Mireille Cailloux
C---------------------------------------------------------------------------
	PROGRAM PRECESSION

	PRINT *,'        VALEURS FOURNIES PAR LE CATALOGUE:'
	PRINT *,' 1) ANNEE:'
	READ(5,*) T0
	PRINT *,' 2) ASCENSION DROITE DONNEE EN: HEURE,MINUTE,SECONDE'
	READ(5,*) ADH,ADM,ADS
	PRINT *,' 2) DECLINAISON DONNEE EN: DEGRE,MINUTE,SECONDE'
	READ(5,*) DD,DM,DS
	PRINT *,' ANNEE QUI NOUS INTERESSE:'
	READ(5,*) T1
	T=(T1+T0)/2.-1900.
	T=T/1000.
	DT=T1-T0
	RD=3.14159/180.
	VM=46.08506+0.27945*T+0.00012*T*T
C VMS : EN SECONDE D"HEURE
	VMS=VM/15.
	VN=20.04685-0.08533*T-0.00037*T*T
	VNS=VN/15.
C VN: EN SECONDE , VNS: EN SECONDE D"HEURE
	ALPHA0=(ADH*3600.+ADM*60.+ADS)
	ALPHA=ALPHA0*15./3600.
C ALPHA EN DEGRES
	COSA=COS(ALPHA*RD)
	SINA=SIN(ALPHA*RD)
	DELTA0=ABS(DD)*3600.+DM*60.+DS
	IF (DD.LT.0.) DELTA0=-DELTA0
	DELTA=DELTA0/3600.
	TAND=TAN(DELTA*RD)
	ALPHA1=ALPHA0+VMS*DT+VNS*DT*SINA*TAND
	DELTA1=DELTA0+VN*DT*COSA
	IDD=INT(DELTA1/3600.)
	B=DELTA1-IDD*3600.
	B=ABS(B)
	IDM=INT(B/60.)
	B1=B-IDM*60.
	PRINT 200
200	FORMAT(/)
	PRINT *,' DECLINAISON:',IDD,' DEGRES',IDM,' MN',B1,'SEC'
	IAH=INT(ALPHA1/3600.)
	C=ALPHA1-IAH*3600.
	IAM=INT(C/60.)
	C1=C-IAM*60.
	PRINT 200
	PRINT *,' ASCENSION DROITE:',IAH,'H',IAM,' MN',C1,'SEC'
	PRINT 200
	STOP
	END


module circle_mod ! GitHub FortranTip xcircle.f90
use iso_c_binding, only: dp => c_double
implicit none
real(kind=dp), bind(c), protected :: pi = 3.14159265359_dp
real(kind=dp), bind(c) :: circumference
! circumference can be modified on the Fortran or C side
end module circle_mod

program main
use circle_mod, only: dp,pi,circumference
interface
!
function area_circle(radius) result(area) bind(c)
import dp
real(kind=dp), intent(in), value :: radius
real(kind=dp)                    :: area
end function area_circle
!
subroutine set_circumference(radius) bind(c)
import dp
real(kind=dp), intent(in), value :: radius
end subroutine set_circumference
!
end interface
real(kind=dp) :: radius = 10.0_dp
print*,"circle area =",area_circle(radius)
call set_circumference(radius)
print*,"circumference =",circumference
end program main
! Compile with


C -------------------------------------------------------------------------
C --------------------------RESPONSESPEC-----------------------------------
C Subroutine to calculate the response spectrum
C -------------------------------------------------------------------------
      subroutine RESPONSESPEC(acc, dt, nt, period, spec, specDur,
     +                        specDis)
      implicit none
      integer                 :: tag, nt, ii, k, i, j
      real                    :: beta, omega, dt, period, pga, spec
      real                    :: b2, o2, o3, pi, specDur, DL, DH
      real                    :: specDurA, DLA, DHA
      real                    :: specDis, specVel
      real, dimension(nt)     :: acc, x1, x2, a1, a2, zz, v2, v2out
      real, dimension(nt)     :: ad, adout
      real, dimension(2,2)    :: A, B
      data pi/3.14159265358979323846/

      omega = 2.0*pi/period
      beta = 0.05
      b2 = beta**2.0
      o2 = omega**2.0
      o3 = omega**3.0

      A(1,1) = exp(-beta*omega*dt)*((beta/sqrt(1.0-b2))*
     +sin(omega*sqrt(1.0-b2)*dt)+ cos(omega*sqrt(1.0-b2)*dt))

      A(1,2) = (exp(-beta*omega*dt)/(omega*sqrt(1.0-b2)))*
     +sin(omega*sqrt(1.0-b2)*dt)

      A(2,1) = A(1,2)*(-1.0)*(o2)

      A(2,2) = exp(-beta*omega*dt)*(-(beta/sqrt(1.0-b2))*
     +sin(omega*sqrt(1.0-b2)*dt)+ cos(omega*sqrt(1.0-b2)*dt))

      B(1,1) = exp(-beta*omega*dt)*((((2.0*b2)-1.0)/(o2*dt) +
     +beta/omega)*sin(omega*sqrt(1.0-b2)*dt)/(omega*sqrt(1.0-b2)) +
     +(((2.0*beta))/(o3*dt) + 1.0/o2)*cos(omega*sqrt(1.0-b2)*dt)) -
     +2.0*beta/((o3)*dt)

      B(1,2) = -exp(-beta*omega*dt)*((((2.0*b2)-1.0)/(o2*dt))*
     +sin(omega*sqrt(1.0-b2)*dt)/(omega*sqrt(1.0-b2)) +
     +(((2.0*beta))/(o3*dt))*cos(omega*sqrt(1.0-b2)*dt))-
     +(1.0/o2)+2.0*beta/((o3)*dt)

      B(2,1) = exp(-beta*omega*dt)*(((((2.0*b2)-1.0)/(o2*dt) +
     +beta/omega)*(cos(omega*sqrt(1.0-b2)*dt) - (beta/sqrt(1.0-b2))*
     +sin(omega*sqrt(1.0-b2)*dt)))- ((2.0*beta)/(o3*dt) + 1.0/o2)*
     +((omega*sqrt(1.0-b2))*sin(omega*sqrt(1.0-b2)*dt) + (beta*omega)*
     +cos(omega*sqrt(1.0-b2)*dt))) + 1.0/(dt*o2)

      B(2,2) = -exp(-beta*omega*dt)*((((2.0*b2)-1.0)/(o2*dt))*
     +(cos(omega*sqrt(1.0-b2)*dt) -
     +(beta/sqrt(1.0-b2))*sin(omega*sqrt(1.0-b2)*dt))-
     +((2.0*beta)/(o3*dt))*((omega*sqrt(1.0-b2))*
     +sin(omega*sqrt(1.0-b2)*dt)+
     +(beta*omega)*cos(omega*sqrt(1.0-b2)*dt))) - 1.0/(dt*o2)

      x1(1)=0.0
      x2(1)=0.0

      a1(1)=acc(1)
      a2(1)=acc(2)
      do ii = 2,nt-1
          a1(ii)=acc(ii)
          a2(ii)=acc(ii+1)
      enddo

      do ii = 2,nt
          x1(ii) = A(1,1)*x1(ii-1)+A(1,2)*x2(ii-1)+
     +B(1,1)*a1(ii-1)+B(1,2)*a2(ii-1)
          x2(ii) = A(2,1)*x1(ii-1)+A(2,2)*x2(ii-1)+
     +B(2,1)*a1(ii-1)+B(2,2)*a2(ii-1)
      enddo

      do k = 1,nt
          zz(k) = abs(-(2.0*beta*omega*x2(k)+o2*x1(k)))
          v2(k) = x2(k)**2.0
      enddo
      spec = maxval(zz)
      specDis = maxval(abs(x1))
      specVel = maxval(abs(x2))
C--------------------------------------------------------------------------
C Duration Calculation and Comparison
      call DINTEG(v2, dt, nt, v2out)

      do j = 1,nt
           v2out(j) = v2out(j)/v2out(nt)
           if(v2out(j).le.0.05) DL = REAL(j-1)*dt
           if(v2out(j).le.0.75) DH = REAL(j-1)*dt
      enddo

      specDur = REAL(DH-DL)/period

C--------------------------------------------------------------------------
C      To calculate the Arias Duration
C      do k = 1,nt
C          ad(k) = (-(2*beta*omega*x2(k)+o2*x1(k)))**2
C      enddo
C      call DINTEG(ad, dt, nt, adout)
C      do j = 1,nt
C           adout(j) = adout(j)/adout(nt)
C           if(adout(j).le.0.05) DLA = REAL(j-1)*dt
C           if(adout(j).le.0.95) DHA = REAL(j-1)*dt
C      enddo
C      specDurA = REAL(DHA-DLA)/period
C--------------------------------------------------------------------------
      end subroutine RESPONSESPEC
C -------------------------------------------------------------------------
C -------------------------------------------------------------------------
C --------------------------RESPSPECNGA-----------------------------------
C Subroutine to calculate the response spectrum
C -------------------------------------------------------------------------
      subroutine RESPSPECNGA(acc, dt, nt, period, zz)
      implicit none
      integer                 :: tag, nt, ii, k, i, j
      real                    :: beta, omega, dt, period, pga, spec
      real                    :: b2, o2, o3, pi, specDur, DL, DH
      real                    :: specDis, specVel
      real, dimension(nt)     :: acc, x1, x2, a1, a2, zz, v2, v2out
      real, dimension(2,2)    :: A, B
      data pi/3.14159265358979323846/

      omega = 2.0*pi/period
      beta = 0.05
      b2 = beta**2.0
      o2 = omega**2.0
      o3 = omega**3.0

      A(1,1) = exp(-beta*omega*dt)*((beta/sqrt(1.0-b2))*
     +sin(omega*sqrt(1.0-b2)*dt)+ cos(omega*sqrt(1.0-b2)*dt))

      A(1,2) = (exp(-beta*omega*dt)/(omega*sqrt(1.0-b2)))*
     +sin(omega*sqrt(1.0-b2)*dt)

      A(2,1) = A(1,2)*(-1.0)*(o2)

      A(2,2) = exp(-beta*omega*dt)*(-(beta/sqrt(1.0-b2))*
     +sin(omega*sqrt(1.0-b2)*dt)+ cos(omega*sqrt(1.0-b2)*dt))

      B(1,1) = exp(-beta*omega*dt)*((((2.0*b2)-1.0)/(o2*dt) +
     +beta/omega)*sin(omega*sqrt(1.0-b2)*dt)/(omega*sqrt(1.0-b2)) +
     +(((2.0*beta))/(o3*dt) + 1.0/o2)*cos(omega*sqrt(1.0-b2)*dt)) -
     +2.0*beta/((o3)*dt)

      B(1,2) = -exp(-beta*omega*dt)*((((2.0*b2)-1.0)/(o2*dt))*
     +sin(omega*sqrt(1.0-b2)*dt)/(omega*sqrt(1.0-b2)) +
     +(((2.0*beta))/(o3*dt))*cos(omega*sqrt(1.0-b2)*dt))-
     +(1.0/o2)+2.0*beta/((o3)*dt)

      B(2,1) = exp(-beta*omega*dt)*(((((2.0*b2)-1.0)/(o2*dt) +
     +beta/omega)*(cos(omega*sqrt(1.0-b2)*dt) - (beta/sqrt(1.0-b2))*
     +sin(omega*sqrt(1.0-b2)*dt)))- ((2.0*beta)/(o3*dt) + 1.0/o2)*
     +((omega*sqrt(1.0-b2))*sin(omega*sqrt(1.0-b2)*dt) + (beta*omega)*
     +cos(omega*sqrt(1.0-b2)*dt))) + 1.0/(dt*o2)

      B(2,2) = -exp(-beta*omega*dt)*((((2.0*b2)-1.0)/(o2*dt))*
     +(cos(omega*sqrt(1.0-b2)*dt) -
     +(beta/sqrt(1.0-b2))*sin(omega*sqrt(1.0-b2)*dt))-
     +((2.0*beta)/(o3*dt))*((omega*sqrt(1.0-b2))*
     +sin(omega*sqrt(1.0-b2)*dt)+
     +(beta*omega)*cos(omega*sqrt(1.0-b2)*dt))) - 1.0/(dt*o2)

      x1(1)=0.0
      x2(1)=0.0

      a1(1)=acc(1)
      a2(1)=acc(2)
      do ii = 2,nt-1
          a1(ii)=acc(ii)
          a2(ii)=acc(ii+1)
      enddo

      do ii = 2,nt
          x1(ii) = A(1,1)*x1(ii-1)+A(1,2)*x2(ii-1)+
     +B(1,1)*a1(ii-1)+B(1,2)*a2(ii-1)
          x2(ii) = A(2,1)*x1(ii-1)+A(2,2)*x2(ii-1)+
     +B(2,1)*a1(ii-1)+B(2,2)*a2(ii-1)
      enddo

      do k = 1,nt
          zz(k) = abs(-(2.0*beta*omega*x2(k)+o2*x1(k)))
      enddo
C--------------------------------------------------------------------------
      end subroutine RESPSPECNGA
C -------------------------------------------------------------------------


! this code calculate the spectrum of a standard thin disk
! the code is based on the formula in the book "accretion
! power in astrophysics" by Frank et al. 1992
! in unit of cm.g.sec

! This is a modification of Feng's code ssd.f. Since the effect of the
! illumination of the thin disk by radiation from the ADAF seems
! to be negligible, I removed the reprocessing effect.

module globals
real(kind=8),save :: dotm,mass,rs,rin,dotme,rout,theta
real(kind=8),parameter :: h=6.626d-27, c=2.9979d+10, k=1.3807d-16, pi=3.1416d0, &
		pc=3.086d+18, solarmass=1.989d+33, g=6.672d-8, sigma=5.67d-5
end module globals

program ssd
use globals
implicit none
real :: y(4),dy(4),w(16),nu(200),fnu(200)
real(kind=8) :: nnu,s
integer :: i,n

! Output file
open(20,file='ssd_alone.dat')

read(*,*) mass
mass=mass*1.d6*solarmass

rs=2.*g*mass/c/c
! Note in the above defination, the factor of 0.1 is included,
! the unit is g/s
dotme=1.39d18*mass/solarmass

read(*,*) dotm
dotm=dotm*dotme

read(*,*) rin
rin=rin*rs
rout=1d5*rs

read(*,*) theta
theta=theta/57.2958 !--------------6-----------------!

do i=1,50
	nu(i)=10.d0**(11.+0.1d0*i)

	nnu=nu(i)
	s=0.d0
	call simpsn(rin,rout,1d-3,8000,n,s,nnu)

	fnu(i)=4.*pi*h*cos(theta)*nu(i)**3.d0/c/c*s
	write(20,*) log10(nu(i)),log10(nu(i)*fnu(i)*4.*pi)
end do

end program

function f(x,nu)
use globals
implicit none
real(kind=8) :: nu
real :: x,tem,fvis,f

! Dissipation rate, see the first page of Chapter 8 in <<accretion>> book
fvis=3./8./pi/sigma*g*mass/x**3.d0*dotm*(1.-(3.*rs/x)**0.5d0)

! Temperature
tem=fvis**0.25d0

if (h*nu/(k*tem).gt.700.) then
	f=0.d0
else
    f=x/(dexp(h*nu/(k*tem))-1.d0)
endif

return
end function

subroutine simpsn(a,b,eps,k,n,s,nu)
implicit none
real(kind=8) :: nu
integer :: n,i,k
real :: a,b,c,h,t1,f,t2,x,s,s0,eps

n=1
c=abs(a)+abs(b)
h=0.5*(b-a)
t1=h*(f(a,nu)+f(b,nu))

do while (c+h /= c)
	x=a-h
    t2=0.5*t1
    do i=1,n
		x=x+2.*h
		t2=t2+h*f(x,nu)
	end do

    s=0.33333333333d0*(4.*t2-t1)
    n=n+n

    if (abs(s-s0).le.(1.+abs(s))*eps) return
	s0=s
    t1=t2
    h=h*0.5
end do

n=-n
return
end subroutine


#include "scalar.fpp"

!=====================================================================!
! This is a simple example of setting up a physical system for time
! dependent analysis. We implement first order decay ODE.
!
! Author: Komahan Boopathy (komahan@gatech.edu)
!=====================================================================!

module decay_ode_class

  use constants                 , only : WP
  use dynamic_physics_interface , only : dynamics

  implicit none

  private

  public :: decay

  !-------------------------------------------------------------------!
  ! Type that implements a decay ordinary differential equation
  !-------------------------------------------------------------------!

  type, extends(dynamics) :: decay

     ! Define constants and other parameters needed for residual and
     ! jacobian assembly here

     type(scalar) :: gamma

   contains

     ! Implement deferred procedures from superclasses
     procedure :: add_residual
     procedure :: add_jacobian
     procedure :: get_initial_condition

     ! Destructor
     final :: destruct

  end type decay

  ! Interface to construct the decay
  interface decay
     procedure construct
  end interface decay

contains

  !===================================================================!
  ! Constructor for decay system
  !===================================================================!

  pure type(decay) function construct(gamma) &
       & result (this)

    type(scalar)  , intent(in) :: gamma

    ! Set the number of state variables of decay system
    call this % set_num_state_vars(1)

    ! Set time order of decay system
    call this % set_differential_order(1)

    ! Set the system parameters
    this % gamma = gamma

  end function construct

  !===================================================================!
  ! Destructor for decay system
  !===================================================================!

  pure subroutine destruct(this)

    type(decay), intent(inout) :: this

  end subroutine destruct

  !===================================================================!
  ! Residual assembly at each time step. This is a mandary function
  ! that the user needs to implement to use the integration
  ! scheme. This is where the differential equations are supplied to
  ! the solver.
  ! ===================================================================!

  pure subroutine add_residual(this, residual, U, X)

    class(decay) , intent(inout) :: this
    type(scalar) , intent(inout) :: residual(:)
    type(scalar) , intent(in)    :: U(:,:)
    type(scalar) , intent(in)    :: X(:,:)

    ! R = qdot + gamma*q
    residual(:) = residual(:) + U(2,:) + this % gamma * U(1,:)

  end subroutine add_residual

  !===================================================================!
  ! Jacobian assembly at each time step.
  !
  ! Jacobian is the matrix of partial derivatives. Each row in the
  ! Jacobian matrix arises from differentiating a single
  ! equation. Each column in the Jacobian comes from a variable in the
  ! problem. Note the NEQN should be equal to NVARS for the system to
  ! be solved.
  !
  ! Note: alpha, beta and gamma are scalars that need to be multiplied
  ! with the partial derivatives DRDQ, DRDudot and DRDuddot
  ! respectively.
  !===================================================================!

  pure subroutine add_jacobian(this, jacobian, coeff, U, X)

    class(decay) , intent(inout) :: this
    type(scalar) , intent(inout) :: jacobian(:,:)
    type(scalar) , intent(in)    :: coeff(:)
    type(scalar) , intent(in)    :: U(:,:)
    type(scalar) , intent(in)    :: X(:,:)

    jacobian(1,1) = jacobian(1,1) + coeff(2) + coeff(1)*this % gamma

  end subroutine add_jacobian

  !===================================================================!
  ! Sets the initial condition for use in the integator. If first order
  ! system just set initial Q, if a second order system set initial Q
  ! and qdot
  !===================================================================!

  pure subroutine get_initial_condition(this, U, X)

    class(decay) , intent(in)    :: this
    type(scalar) , intent(inout) :: U(:,:)
    type(scalar) , intent(in)    :: X(:,:)

    U(1,:) = 1.0d0

  end subroutine get_initial_condition

end module decay_ode_class


      subroutine evol_alphaopl(n_K,n_alpha,np1_K,np1_alpha,x,Nx,gma,gmb,
     &ht,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 gma
      real*8 gmb
      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(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = np1_alpha(i) - 0.2D1 / (gma * np1_alpha(i) ** gmb * gmb * np1
     #_K(i) * ht + 0.2D1 * np1_alpha(i)) * ht * np1_alpha(i) * ((-0.1D1
     #* n_alpha(i) + np1_alpha(i)) / ht + 0.5000000000000000D0 * gma * n
     #p1_alpha(i) ** gmb * np1_K(i) + 0.5000000000000000D0 * gma * n_alp
     #ha(i) ** gmb * n_K(i))
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = np1_alpha(i) - 0.2D1 / (gma * np1_alpha(i) ** gmb * gmb * np1
     #_K(i) * ht + 0.2D1 * np1_alpha(i)) * ht * np1_alpha(i) * ((-0.1D1
     #* n_alpha(i) + np1_alpha(i)) / ht + 0.5000000000000000D0 * gma * n
     #p1_alpha(i) ** gmb * np1_K(i) + 0.5000000000000000D0 * gma * n_alp
     #ha(i) ** gmb * n_K(i))
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = -0.1D1 * myzero * x(i) + 0.1D1
      res(i)=qb
      end do
      endif
      END


program inv
 implicit none
! by convention we define a MISSING value
 real, parameter   :: MISSING = -2147483647.0
 character(len=32) :: arg
 logical           :: ltests = .FALSE.
 real              :: val

 if (command_argument_count() > 0) then
! We assume one argument only (ignore other arguments)
   call get_command_argument(1, arg)
   if (trim(arg) == '-t' .OR. trim(arg) == '--tests' &
       .OR. trim(arg) == '--test') then
       LTESTS=.TRUE.
   else
     write(*,*) 'Error: program argument', trim(arg), &
                ' is unknown'
     call usage
     STOP
   end if
 endif

 if (LTESTS) then
   print*, 'Running test suite'
   call runTests
 else
   write(*,*) 'Enter a non-zero real value: '
   read(*,*) val
   write(*,*) 'The value of 1/', val, ' is ', runProg(val)
 endif

contains
!*************************************************
! print the usage of this program
!
 subroutine usage
   implicit none
   character(len=100) :: progName

   CALL get_command_argument(0, progName)
   write(*,*) 'usage: ', trim(progName), ' [-t | --test | --tests] '

 end subroutine usage
!*************************************************
! Compute 1/x
!
 real function runProg(val)
   implicit none

   real, intent(in) :: val

! Check val and set result to MISSING if null
  if (val== 0.0) then
   runProg = MISSING
  else
   runProg = 1/val
  endif

 end function runProg
!*************************************************
! Run tests for different predefined values
!
subroutine runTests
  implicit none

  real, parameter  :: EPS=1e-7
  real                         :: val, res
  character(len=32)            :: str

! Test code for 0
  val=0.0
  res=runProg(val)

  if (res == MISSING) then
    print*, 'Test-1 OK'
  else
    print*, 'Test-1 FAILED'
  endif
! Test code for huge values
  val=huge(val)
  res=runProg(val)
  if ( res >=-EPS .and. res <= EPS) then
    print*, 'Test-2 OK'
  else
    print*, 'Test-2 FAILED'
  endif
! Test code for known values
  val = 4.
  res= runProg(val)
  if (res /= 0.25) then
    print*, 'Test-3 FAILED'
  else
    print*, 'Test-3 OK'
  endif
! Test for 3
  val= 3.0
  res= runProg(val)
  if (res >= 1./3.0 -EPS .AND. res <= 1/3. + EPS) then
    print*, 'Test-4 OK'
  else
    print*, 'Test-4 FAILED'
  endif
 end subroutine runTests

end program inv


C
C $Id: wtprin.f,v 1.4 2008-09-18 00:42:18 kennison Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE WTPRIN (UVAL,VVAL,DLAT,DLON,CSLT)
C
        DOUBLE PRECISION UVAL,VVAL,DLAT,DLON,CSLT
C
C The subroutine WTPRIN implements the inverse of the Winkel tripel
C projection, using an iterative algorithm due to Cengizhan Ipbuker,
C of the Istanbul Technical University, in Istanbul, Turkey, and Oztug
C Bildirici, of Selcuk University, in Konya, Turkey.  Their paper is
C called "A General Algorithm for the Inverse Transformation of Map
C Projections Using Jacobian Matrices", and it was published in the
C proceedings of the Third International Symposium on Mathematical and
C Computational Applications, September 4-6, 2002 (pp. 175-182).
C
C UVAL and VVAL are input values of U and V, in the projection plane.
C DLAT and DLON are output values of latitude and longitude, in radians.
C CSLT is the cosine of the standard parallel of the Winkel tripel, for
C which Winkel used ACOS(2/PI); in EZMAP, though, it is allowed to vary.
C
C The common block MAPCM0 contains mathematical constants.
C
        COMMON /MAPCM0/  COS1,DTOR,DTRH,OOPI,PI,PIOF,PIOT,RTDD,RTOD,
     +                   SROT,SIN1,TOPI,TSRT
        DOUBLE PRECISION COS1,DTOR,DTRH,OOPI,PI,PIOF,PIOT,RTDD,RTOD,
     +                   SROT,SIN1,TOPI,TSRT
        SAVE   /MAPCM0/
C
C Local variables.
C
        DOUBLE PRECISION CVAL,DLAP,DLOP,DNOM,DVAL,PULA,PULO,PVLA, PVLO,
     +                   TVAL,UDIF,VDIF
C
C First, we must check the point (UVAL,VVAL) to see if it lies in the
C region occupied by the projection of the globe.  IOOR will be set to
C 0 if so, and to 1 otherwise.  ("OOR" stands for "Out Of Range".)
C
        IOOR=0
C
C The first condition in the following block-if expresses the condition
C that the point (UVAL,VVAL) is outside the bounding rectangle of the
C area occupied by the projection of the globe.  If not, and if it is
C not in the central rectangle, we do a more complicated test to see if
C it is inside or outside one of the curved end pieces of the area.
C
        IF (ABS(UVAL)-PIOT*(CSLT+1.D0).GT.1.D-9.OR.
     +      ABS(VVAL)-PIOT.GT.1.D-9) THEN
          IOOR=1
        ELSE IF (ABS(UVAL).GT.PIOT*CSLT) THEN
          DLAT=ACOS(ABS(UVAL)/PIOT-CSLT)
          IF (ABS(VVAL)-(.5D0*DLAT+PIOF*SIN(DLAT)).GT.1.D-9) IOOR=1
        END IF
C
C If the input point is out of range, return the value "1.D12" to
C signal the fact.
C
        IF (IOOR.NE.0) THEN
          DLAT=1.D12
          DLON=1.D12
          RETURN
        END IF
C
C Ipbuker and Bildirici's algorithm makes use of partial derivatives
C of the forward projection functions, which are usually expressed
C using the SINC function, which is carefully defined so as not to
C cause problems when its argument is zero.  To facilitate the taking
C of partial derivatives, the SINC function was replaced by a more
C conventional expression, and it may be that which causes problems
C for the algorithm along the equator.  In any case, the following
C code takes care of the problem:
C
        IF (ABS(VVAL).LT.1.D-12) THEN
          DLAT=VVAL
          DLON=2.D0*UVAL/(CSLT+1.D0)
          RETURN
        END IF
C
C Set up the iteration loop.  DLAP and DLOP hold values of latitude and
C longitude from the previous iteration; they are given initial values
C that represent a guess at the proper values.
C
        DLAP=.999D0*VVAL
        DLOP=DLAP*(CSLT+COS(DLAP))
C
C NITR keeps track of the number of iterations performed, which is
C limited to 20.  (Actually, my tests indicate that a maximum of 7
C iterations suffice to give full double-precision accuracy.)
C
        NITR=1
C
C Iteration loop.  First, compute terms that occur frequently.
C
  101   TVAL=COS(DLAP)*COS(.5D0*DLOP)
C
        CVAL=1.D0-TVAL**2
        DVAL=ACOS(TVAL)
C
C To follow this code, refer to Ipbuker and Bildirici's paper.  UDIF
C and VDIF are functions of latitude and longitude expressing the
C difference between the projected values at a lat/lon position and
C the desired values.  Each of PULA, PULO, PVLA, and PVLO is a partial
C derivative of either U or V with respect to either latitude or
C longitude.
C
        TVAL=DVAL/SQRT(CVAL)
C
        UDIF=.5D0*(2.D0*TVAL*COS(DLAP)*SIN(.5D0*DLOP)+DLOP*CSLT)-UVAL
        VDIF=.5D0*(TVAL*SIN(DLAP)+DLAP)-VVAL
C
        TVAL=TVAL/CVAL
C
        PULA=SIN(DLOP)*SIN(2.D0*DLAP)/(4.D0*CVAL)-
     +       TVAL*SIN(DLAP)*SIN(.5D0*DLOP)
        PULO=.5D0*(COS(DLAP)**2*SIN(.5D0*DLOP)**2/CVAL+
     +           TVAL*COS(DLAP)*COS(.5D0*DLOP)*SIN(DLAP)**2+CSLT)
        PVLA=.5D0*(SIN(DLAP)**2*COS(.5D0*DLOP)/CVAL+
     +           TVAL*SIN(.5D0*DLOP)**2*COS(DLAP)+1.D0)
        PVLO=.125D0*(SIN(2.D0*DLAP)*SIN(.5D0*DLOP)/CVAL-
     +             TVAL*SIN(DLAP)*COS(DLAP)**2*SIN(DLOP))
C
        DNOM=PULA*PVLO-PVLA*PULO
C
C DLAT and DLON are improved values of latitude and longitude.
C
        DLAT=DLAP-(UDIF*PVLO-VDIF*PULO)/DNOM
        DLON=DLOP-(VDIF*PULA-UDIF*PVLA)/DNOM
C
C If the improved values are not sufficiently different from the
C previous values and fewer than 20 iterations have been performed,
C go back for another one.  Otherwise, just return DLAT and DLON.
C
        IF (ABS(DLAT-DLAP).GT.1.D-12.OR.ABS(DLON-DLOP).GT.1.D-12) THEN
          IF (NITR.LT.20) THEN
            DLAP=DLAT
            DLOP=DLON
            NITR=NITR+1
            GO TO 101
          END IF
        END IF
C
C Done.
C
        RETURN
C
      END


program goldenratio
    implicit none
    real :: temp,bp,ar,br,power,recursion
    integer :: i
    print*, "Iteration(n) | ----------- RECURSION VALUES ---------------------|----------------- POWER VALUES -----------|--&
    ------------------------ Ratio -----------|"
    bp=(-sqrt(5.0)+3)/2
    br=(-sqrt(5.0)+3)/2 ; ar =(sqrt(5.0)-1)/2
    do i=2,25
        write(*,'(I3,f50.30)', advance = 'no') i,recursion(ar,br)
        temp = br ; br = recursion(ar,br); ar = temp
        write(*,'(f50.30,f50.30)') power(bp), abs(br/power(bp))
        bp = power(bp)
    end do
end program goldenratio

function power(a)
    real ::a
    power = a*(sqrt(5.0)-1)/2
end function

function recursion(a,b)
    real :: a,b,recursion
    recursion = (a-b)
end function