c     ===================================
c     MAIN PROGRAM
c		This program takes a function and
c		computes its definite integral in
c		a region (a, b)
c     ===================================
      program main

c	  Variables
      real*8 a, b, x1, x2
      real*8 f
      a = 0.0d0
      b = 2.0d0*datan(1.0d0)
      x1 = -1.0d0
      x2 = 1.0d0

      res = f(x1,a,b) + f(x2,a,b)
      write(*,*) 'result:', res

      end

c     =========================================
c	  FUNCTION
c		Definition of the function to integrate
c     =========================================
      real*8 function f(x,a,b)
      real*8 x, a, b

      f = ((b-a)/2.0d0)*log( -1.0d0 + ((b+a)/2.0d0) + x*(b-a)/2.0d0 )

      return
      end

computational math/numerical integral calculation - differential equation integration 1.(b2).f


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran77 Subroutines and Programs         *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
!
!     11/96
!
!     a program for testing all vector analysis and synthesis subroutines
!
!     (1) first a scalar stream function and a scalar velocity potential function
!         are set in st, sv by restricting polys in x, y, z to the sphere surface
!
!     (2) the vector vield (v, w) is set by analytically differenting the scalar fields in (1)
!         using the standard formula relating a vector field and the stream and velocity
!         potential scalar fields in colatitude X longitude spherical coordinates
!
!          v = -1/sin(theta)*d(st)/dphi + d(sv)/dtheta
!
!          w =  1/sin(theta)*d(sv)/dphi + d(st)/dtheta
!
!     (3) a vector analysis is performed on (v, w)
!
!     (4) a vector synthesis is performed using coeffs from (3)
!
!     (5) the synthesized vector field from (4) is compared with the vector field from (2)
!
!     note:  vhaec, vhaes, vhagc, vhags, vhsec, vhses, vhsgc, vhsgs are all tested!
!
program test_all_vector_analysis_and_synthesis_routines

    use spherepack

    ! Explicit typing only
    implicit none

    ! Dictionary
    integer(ip), parameter              :: NLAT= 25, NLON= 19, NT = 2
    integer(ip), parameter              :: ITYP = 0
    real(wp), dimension(NLAT, NLAT, NT) :: br, bi, cr, ci
    real(wp), dimension(NLAT, NLON, NT) :: st, sv, v, w
    real(wp), dimension(NLAT)           :: gaussian_latitudes, gaussian_weights
    real(wp), allocatable               :: wavetable(:)
    real(wp)                            :: cosp, cost, dlat, dphi
    real(wp)                            :: dstdp, dstdt, dsvdp, dsvdt
    real(wp)                            :: dxdp, dxdt, dydp, dydt, dzdp, dzdt
    real(wp)                            :: err2v, err2w
    integer(ip)                         :: i, j, k, icase
    integer(ip)                         :: error_flag
    real(wp)                            :: phi, sinp, sint, theta
    real(wp)                            :: ve, we, x, y, z

    call name("Testing all vector analysis and synthesis procedures")

    ! Set dimension variables
    call iout(NLAT, "nlat")
    call iout(NLON, "nlon")
    call iout(NT, "  nt")

    ! Set equally spaced colatitude and longitude increments
    dphi = TWO_PI/NLON
    dlat = PI/(NLAT-1)

    ! Compute nlat-many gaussian latitudinal points
    call compute_gaussian_latitudes_and_weights(NLAT, gaussian_latitudes, gaussian_weights, error_flag)

    call name("gaqd")
    call iout(error_flag, " ier")
    call vecout(gaussian_latitudes, "thtg", NLAT)

    ! Test all analysis and synthesis subroutines
    do icase=1, 4

        call name("*******************************")

        ! Set scalar stream and velocity potential fields as polys in x, y, z
        ! and then set v, w from st, sv scalar fields
        do k=1, NT
            do j=1, NLON
                phi = real(j - 1, kind=wp) * dphi
                sinp = sin(phi)
                cosp = cos(phi)
                do i=1, NLAT
                    select case (icase)
                        case (0:2)
                            theta = real(i-1, kind=wp) * dlat
                        case default
                            theta = gaussian_latitudes(i)
                    end select
                    cost = cos(theta)
                    sint = sin(theta)
                    x = sint*cosp
                    y = sint*sinp
                    z = cost
                    dxdt = cost*cosp
                    dxdp = -sint*sinp
                    dydt = cost*sinp
                    dydp = sint*cosp
                    dzdt = -sint
                    dzdp = 0.0_wp
                    select case (k)
                        case (1)
                            st(i, j, k) = x*y
                            sv(i, j, k) = y*z
                            dstdt = x*dydt+y*dxdt
                            dstdp = x*dydp+y*dxdp
                            dsvdt = y*dzdt+z*dydt
                            dsvdp = y*dzdp+z*dydp
                            v(i, j, k) = -(cosp*dydp+sinp*dxdp) + dsvdt
                            w(i, j, k) = sinp*dzdp + cost*cosp + dstdt
                        case (2)
                            st(i, j, k) = x*z
                            sv(i, j, k) = x*y
                            dstdp = x*dzdp+z*dxdp
                            dstdt = x*dzdt+z*dxdt
                            dsvdp = x*dydp+y*dxdp
                            dsvdt = x*dydt+y*dxdt

                            ! v = -1/sin(theta)*d(st)/dphi + d(sv)/dtheta
                            v(i, j, k) = z*sinp + dsvdt

                            ! w =  1/sin(theta)*d(sv)/dphi + d(st)/dtheta
                            w(i, j, k) = cosp*dydp+ sinp*dxdp + dstdt
                    end select
                end do
            end do
        end do

        select case (icase)
            case (1)

                call name("testing vhaec and vhsec")
                call initialize_vhaec(NLAT, NLON, wavetable, error_flag)
                call name("initialize_vhaec")
                call iout(error_flag, "error_flag = ")
                call vhaec(NLAT, NLON, ITYP, NT, v, w, NLAT, NLON, br, bi, cr, ci, NLAT, &
                    NLAT, wavetable, error_flag)
                call name("vhaec")
                call iout(error_flag, "error_flag = ")

                !  Now synthesize v, w from br, bi, cr, ci and compare with original
                call initialize_vhsec(NLAT, NLON, wavetable, error_flag)
                call name("initialize_vhsec")
                call iout(error_flag, "error_flag = ")
                call vhsec(NLAT, NLON, ITYP, NT, v, w, NLAT, NLON, br, bi, cr, ci, NLAT, &
                    NLAT, wavetable, error_flag)
                call name("vhsec")
                call iout(error_flag, "error_flag = ")
            case (2)

                call name("testing vhaes and vhses")
                call initialize_vhaes(NLAT, NLON, wavetable, error_flag)
                call name("initialize_vhaes")
                call iout(error_flag, "error_flag = ")
                call vhaes(NLAT, NLON, ITYP, NT, v, w, NLAT, NLON, br, bi, cr, ci, NLAT, &
                    NLAT, wavetable, error_flag)
                call name("vhaes")
                call iout(error_flag, "error_flag = ")

                ! Now synthesize v, w from br, bi, cr, ci and compare with original
                call initialize_vhses(NLAT, NLON, wavetable, error_flag)
                call name("initialize_vhses")
                call iout(error_flag, "error_flag = ")
                call vhses(NLAT, NLON, ITYP, NT, v, w, NLAT, NLON, br, bi, cr, ci, NLAT, &
                    NLAT, wavetable, error_flag)
                call name("vhses")
                call iout(error_flag, "error_flag = ")
            case (3)

                call name("testing vhagc and vhsgc")
                call iout(NLAT, "nlat")
                call initialize_vhagc(NLAT, NLON, wavetable, error_flag)
                call name("initialize_vhagc")
                call iout(error_flag, "error_flag = ")
                call vhagc(NLAT, NLON, ITYP, NT, v, w, NLAT, NLON, br, bi, cr, ci, NLAT, &
                    NLAT, wavetable, error_flag)
                call name("vhagc")
                call iout(error_flag, "error_flag = ")

                ! Now synthesize v, w from br, bi, cr, ci and compare with original
                call initialize_vhsgc(NLAT, NLON, wavetable, error_flag)
                call name("initialize_vhsgc")
                call iout(error_flag, "error_flag = ")

                call vhsgc(NLAT, NLON, ITYP, NT, v, w, NLAT, NLON, br, bi, cr, ci, NLAT, &
                    NLAT, wavetable, error_flag)
                call name("vhsgc")
                call iout(error_flag, "error_flag = ")
            case (4)

                call name("testing vhags and vhsgs")
                call initialize_vhags(NLAT, NLON, wavetable, error_flag)
                call name("initialize_vhags")
                call iout(error_flag, "error_flag = ")
                call vhags(NLAT, NLON, ITYP, NT, v, w, NLAT, NLON, br, bi, cr, ci, NLAT, &
                    NLAT, wavetable, error_flag)
                call name("vhags")
                call iout(error_flag, "error_flag = ")

                ! Now synthesize v, w from br, bi, cr, ci and compare with original
                call initialize_vhsgs(NLAT, NLON, wavetable, error_flag)
                call name("initialize_vhsgs")
                call iout(error_flag, "error_flag = ")
                call vhsgs(NLAT, NLON, ITYP, NT, v, w, NLAT, NLON, br, bi, cr, ci, NLAT, &
                    NLAT, wavetable, error_flag)
                call name("vhsgs")
                call iout(error_flag, "error_flag = ")
        end select

        err2v = 0.0_wp
        err2w = 0.0_wp
        do k=1, NT
            do j=1, NLON
                phi = real(j - 1, kind=wp)*dphi
                sinp = sin(phi)
                cosp = cos(phi)
                do i=1, NLAT
                    select case (icase)
                        case (0:2)
                            theta = real(i-1, kind=wp) * dlat
                        case default
                            theta = gaussian_latitudes(i)
                    end select
                    cost = cos(theta)
                    sint = sin(theta)
                    x = sint*cosp
                    y = sint*sinp
                    z = cost
                    dxdt = cost*cosp
                    dxdp = -sint*sinp
                    dydt = cost*sinp
                    dydp = sint*cosp
                    dzdt = -sint
                    dzdp = 0.0
                    select case (k)
                        case (1)
                            st(i, j, k) = x*y
                            sv(i, j, k) = y*z
                            dstdt = x*dydt+y*dxdt
                            dstdp = x*dydp+y*dxdp
                            dsvdt = y*dzdt+z*dydt
                            dsvdp = y*dzdp+z*dydp
                            ve = -(cosp*dydp+sinp*dxdp) + dsvdt
                            we = sinp*dzdp + cost*cosp + dstdt
                        case (2)
                            st(i, j, k) = x*z
                            sv(i, j, k) = x*y
                            dstdp = x*dzdp+z*dxdp
                            dstdt = x*dzdt+z*dxdt
                            dsvdp =  x*dydp+y*dxdp
                            dsvdt = x*dydt+y*dxdt
                            ve = z*sinp + dsvdt
                            we = cosp*dydp+ sinp*dxdp + dstdt
                    end select
                    err2v = err2v + (v(i, j, k) - ve)**2
                    err2w = err2w + (w(i, j, k) - we)**2
                end do
            end do
        end do

        ! Set and print least squares error in v, w
        err2v = sqrt(err2v/(NT*NLAT*NLON))
        err2w = sqrt(err2w/(NT*NLAT*NLON))
        call vout(err2v, "errv")
        call vout(err2w, "errw")
    end do

    ! Release memory
    deallocate (wavetable)

end program test_all_vector_analysis_and_synthesis_routines


program pi_index_test

  use mo_kind,        only: dp,i4, i8
  use mo_ansi_colors, only: color, c_red, c_green
  use mo_sobol,       only: sobol
  use mo_model,       only: getrange, model
  use mo_pi_index,    only: pi_index

  implicit none

  integer(i4), parameter                 :: npara = 4                    ! number of parameter
  integer(i4), parameter                 :: nsets = 400                  ! number of parametersets
  integer(i4), parameter                 :: nx = 10                      ! number of variable values
  real(dp),    parameter                 :: delta = 0.01_dp              ! delta used for derivative approximation
  integer(i8)                            :: skip = 30000_i8              ! used for generating parameter sets via sobol sequences

  ! Samples and Model Output
  real(dp),    dimension(npara,2)        :: ParaRange                    ! array: Parameter ranges (Min, Max)
  real(dp),    dimension(nx)             :: x                            ! array: variable values, e.g. time points

  ! PI index
  real(dp),    dimension(npara)          :: sample, sample_delta         ! parameter sets: nominal and 1% changed set
  real(dp),    dimension(nx)             :: output_ref, output_delta     ! model output (time series)
  !                                                                      ! for nominal and 1% changed parameter set
  real(dp),    dimension(nsets*nx,npara) :: s_matrix                     ! sensitivity matrix S
  real(dp),    dimension(npara)          :: pi                           ! Parameter importance index
  real(dp),    dimension(:), allocatable :: bi                           ! B index
  integer(i4), dimension(:), allocatable :: counter_pi                   ! number of valid entries in ith column of matrix S
  integer(i8)                            :: seed                         ! seed sobol sequence

  ! Dummy variables
  integer(i4)                            :: set, para, i
  logical                                :: isgood = .true.

  ParaRange = GetRange()

  ! ------------------------------------------------------------------
  ! variable values, e.g. time points
  ! ------------------------------------------------------------------
  do i=1,nx
     x(i) = real(i,dp) * 0.1_dp
  end do

  ! ------------------------------------------------------------------
  ! Generating sensitivity matrix S using Sobol sequences
  ! ------------------------------------------------------------------
  seed = 0
  call sobol(int(npara,i8), seed, sample)
  do set = 1,nsets
     ! sobol sequence
     call sobol(int(npara,i8), skip, sample)
     ! scaling
     sample(:)  = ParaRange(:,1) + sample(:) * (ParaRange(:,2) - ParaRange(:,1))
     output_ref = model(sample,x)
     do para=1,npara
        sample_delta(:)    = sample(:)
        sample_delta(para) = (1.+delta) * sample_delta(para)
        output_delta       = model(sample_delta,x)
        s_matrix((set-1)*nx+1:set*nx,para) = ( output_delta - output_ref ) / ( delta ) * sample(para) / output_ref
     end do
  end do

  ! ------------------------------------------------------------------
  ! Calculate Parameter Importance (PI) index
  ! ------------------------------------------------------------------
  call pi_index(pi, s=s_matrix, norm=1_i4, domad=.true., counter=counter_pi, b_index=bi)

  ! ------------------------------------------------------------------
  ! Printing and checking
  ! ------------------------------------------------------------------
  write(*,'(A48)') '------------------------------------------------'
  write(*,'(A48)') '        PI index    &    B index                '
  write(*,'(A48)') '------------------------------------------------'
  write(*,'(A48)') 'para  PI       B index     (number valid values)'
  do para=1,npara
     write(*,'(I4,A2,F7.4,A2,F7.4,A6,I5,A15)') para, '  ', pi(para), '  ', bi(para), '     (', counter_pi(para),'              )'
  end do
  write(*,'(A48)') '------------------------------------------------'
  write(*,*) ' '

  if (nint(pi(1)*10000._dp)        .ne.  702_i4)  isgood = .false.
  if (nint(pi(2)*10000._dp)        .ne. 1415_i4)  isgood = .false.
  if (nint(pi(3)*10000._dp)        .ne. 3059_i4)  isgood = .false.
  if (nint(pi(4)*10000._dp)        .ne. 4824_i4)  isgood = .false.
  if (nint(bi(1)*10000._dp)        .ne.  271_i4)  isgood = .false.
  if (nint(bi(2)*10000._dp)        .ne.  788_i4)  isgood = .false.
  if (nint(bi(3)*10000._dp)        .ne. 2659_i4)  isgood = .false.
  if (nint(bi(4)*10000._dp)        .ne. 6282_i4)  isgood = .false.

  if (isgood) then
     write(*,*) 'mo_pi_index ', color('o.k.', c_green)
  else
     write(*,*) 'mo_pi_index ', color('failed', c_red)
  end if

END PROGRAM pi_index_test


! Created by EverLookNeverSee@GitHub on 5/30/20
! For more information see FCS/img/Exercise_05.png

program main
    implicit none
    ! declaring variables
    complex :: a, b, c, z_1, z_2, delta, sqr_delta
    ! getting coefficients from user
    print *, "Please enter coefficients:(a, b, c):"
    read *, a
    read *, b
    read *, c
    ! calculating dscriminant
    delta = b ** 2 - 4 * a * c
    sqr_delta = csqrt(delta)
    ! calculating roots
    z_1 = (-b + sqr_delta) / (2 * a)
    z_2 = (-b - sqr_delta) / (2 * a)
    ! printing results
    print *, "z_1:", z_1, "z_2:", z_2
end program main


module random

implicit none (type, external)

interface std
procedure std_int, std_real
end interface

interface mean
procedure mean_int, mean_real
end interface

contains

subroutine rand_init(repeatable, image_distinct)
!! if intrinsic random_init available, use it.
logical, intent(in) :: repeatable, image_distinct

@_random_init@

end subroutine rand_init

impure elemental integer function randint(lo, hi)
integer, intent(in) :: lo, hi
real :: r

call random_number(r)

randint = floor(r * (hi + 1 - lo)) + lo

end function randint

!=========================================
pure real function std_real(A) result(std)
real, intent(in) :: A(:)

std = sqrt(sum(abs(A-mean(A))**2) / (size(A)-1))

end function std_real

pure real function std_int(A) result(std)
integer, intent(in) :: A(:)

std = sqrt(sum(abs(A-mean(A))**2) / size(A))

end function std_int
!==============================================

pure real function mean_real(A) result(mean)
real, intent(in) :: A(:)

mean = sum(A) / size(A)

end function mean_real

pure real function mean_int(A) result(mean)
integer, intent(in) :: A(:)

mean = sum(A) / real(size(A))  ! real coerces

end function mean_int

end module random


subroutine delsph(flat1,flon1,flat2,flon2,del)
implicit none
real,parameter:: R=6371.0
REAL,parameter:: pi=3.1415926535898
real flat1,flat2
real flon1,flon2
real del

real dlat
real dlon
real lat1
real lat2
real a
real c

!dlat=(flat2-flat1)*pi/180
!dlon=(flon2-flon1)*pi/180
!lat1=flat1*pi/180
!lat2=flat2*pi/180
dlat=flat2-flat1
dlon=flon2-flon1
lat1=pi/2-flat1
lat2=pi/2-flat2
a=sin(dlat/2)*sin(dlat/2)+sin(dlon/2)*sin(dlon/2)*cos(lat1)*cos(lat2)
c=2*atan2(sqrt(a),sqrt(1-a))
del=R*c
end subroutine


      subroutine ire_daax(n_DDLthetatheta,n_DDLxx,n_JSthth,n_JSxx,n_Pxx,
     &n_RRthetatheta,n_RRxx,n_Uxx,n_alpha,n_em4phi,n_metthetatheta,n_met
     &xx,nm1_Axx,np1_Axx,Nx,ht,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 n_DDLthetatheta(Nx)
      real*8 n_DDLxx(Nx)
      real*8 n_JSthth(Nx)
      real*8 n_JSxx(Nx)
      real*8 n_Pxx(Nx)
      real*8 n_RRthetatheta(Nx)
      real*8 n_RRxx(Nx)
      real*8 n_Uxx(Nx)
      real*8 n_alpha(Nx)
      real*8 n_em4phi(Nx)
      real*8 n_metthetatheta(Nx)
      real*8 n_metxx(Nx)
      real*8 nm1_Axx(Nx)
      real*8 np1_Axx(Nx)
      real*8 res
      real*8 qb
      res = 0.0D0
      do i=1, Nx, 1
      qb = 0.5000000000000000D0 * (-0.1D1 * nm1_Axx(i) + np1_Axx(i)) / h
     #t - 0.6666666666666667D0 * n_alpha(i) * n_RRxx(i) * n_em4phi(i) +
     #0.6666666666666667D0 * n_em4phi(i) * n_alpha(i) * n_JSxx(i) + 0.66
     #66666666666667D0 / n_metthetatheta(i) * n_alpha(i) * n_metxx(i) *
     #n_RRthetatheta(i) * n_em4phi(i) - 0.6666666666666667D0 / n_metthet
     #atheta(i) * n_alpha(i) * n_metxx(i) * n_JSthth(i) * n_em4phi(i) -
     #0.1D1 * n_alpha(i) * n_Uxx(i) + 0.6666666666666667D0 * n_DDLxx(i)
     #* n_em4phi(i) - 0.6666666666666667D0 / n_metthetatheta(i) * n_DDLt
     #hetatheta(i) * n_metxx(i) * n_em4phi(i) - 0.1D1 * n_Pxx(i)
      res = res + qb**2
      end do
      res = sqrt(res/(1*Nx))
      END


FUNCTION snrm_sp(sx,itol)
  USE mo_kind, only: sp, i4
  IMPLICIT NONE
  REAL(SP), DIMENSION(:), INTENT(IN) :: sx
  INTEGER(I4), INTENT(IN) :: itol
  REAL(SP) :: snrm_sp
  if (itol <= 3) then
     snrm_sp=sqrt(dot_product(sx,sx))
  else
     snrm_sp=maxval(abs(sx))
  end if
END FUNCTION snrm_sp

FUNCTION snrm_dp(sx,itol)
  USE mo_kind, only: dp, i4
  IMPLICIT NONE
  REAL(DP), DIMENSION(:), INTENT(IN) :: sx
  INTEGER(I4), INTENT(IN) :: itol
  REAL(DP) :: snrm_dp
  if (itol <= 3) then
     snrm_dp=sqrt(dot_product(sx,sx))
  else
     snrm_dp=maxval(abs(sx))
  end if
END FUNCTION snrm_dp


module linalg_mod
implicit none

private

public  :: norm                 ! Get the norm of a vector or matrix

interface norm
    procedure norm_dbl_1d, norm_dbl_2d
end interface norm

contains

! Norm function
function norm_dbl_1d(array) result(the_norm)
implicit none
    double precision, intent(in)    :: array(:)
    double precision                :: the_norm

    the_norm = sqrt(sum(array**2))

end function norm_dbl_1d

function norm_dbl_2d(array) result(the_norm)
implicit none
    double precision, intent(in)    :: array(:,:)
    double precision                :: the_norm

    the_norm = sqrt(sum(array**2))

end function norm_dbl_2d

end module linalg_mod


       module math

       interface tsum
         module procedure tsum
       end interface

       interface sum
         module procedure cum_sum
       end interface

       interface dot_product
         module procedure dot_product_arr
       end interface

       interface zbrent
          module procedure zbrent
          module procedure zbrent_array
       end interface

       contains

       pure function dot_product_arr(a,b) result(dot)
       real(kind=8), dimension(:,:), intent(in) :: a,b
       real(kind=8), dimension(size(a,1)) :: dot
       integer :: i
       dot=0d0
       do i=1,size(a,2); dot=dot+a(:,i)*b(:,i); enddo
       end function dot_product_arr

       function tsum(x,y)
       real(kind=8), intent(in), dimension(:) :: x
       real(kind=8), intent(in), dimension(:) :: y
       integer :: n
       real(kind=8), dimension(size(x)) :: tsum,tsumint
       real(kind=8), dimension(size(x)-1) :: xdif, yavg
       n=size(x)
       xdif=x(2:n)-x(1:n-1)
       yavg=(y(1:n-1)+y(2:n))/2d0
       tsumint(1)=0d0
       tsumint(2:n)=xdif*yavg
!       write(6,*) 'y: ',y
!       write(6,*) 'xdif yavg: ',xdif(size(x)-1), yavg(size(x)-1)
       tsum=sum(tsumint,1)
       end function tsum

       function cum_sum(x,cumu)
       real(kind=8), intent(in), dimension(:) :: x
       real(kind=8), dimension(size(x)) :: cum_sum
       integer :: i
       integer, intent(in) :: cumu
       do i=1,size(x)
         cum_sum(i)=sum(x(1:i))
       enddo
       end function cum_sum

       function zbrent(func,x1,x2,args,tol)
         implicit none
         interface
            function func(x,args)
              implicit none
              real(8), intent(in) :: x
              real(8), intent(in), dimension(:) :: args
              real(8)             :: func
            end function func
         end interface
         real(8), intent(in), dimension(:) :: args
         real(8), intent(in) :: x1,x2,tol
         real(8)             :: zbrent
         integer, parameter  :: itmax=100
         real(8), parameter  :: eps=epsilon(x1)
         integer             :: iter
         real(8)             :: a,b,c,d,e,fa,fb,fc,p,q,r,s,tol1,xm
         a=x1       ; b=x2
         fa=func(a,args) ; fb=func(b,args)
         if ((fa > 0.0 .AND. fb > 0.0) .OR. (fa < 0.0 .AND. fb < 0.0))then
            write(*,"(A)")'ROOT MUST BE BRACKETED FOR ZBRENT'
            write(*,*) x1,x2,fa,fb
            stop
         endif

         c=b ; fc=fb
         do iter=1,itmax
            if ((fb > 0.0 .AND. fc > 0.0) .OR. (fb < 0.0 .AND. fc < 0.0)) then
               c=a
               fc=fa
               d=b-a
               e=d
            end if
            if (abs(fc) < abs(fb)) then
               a=b
               b=c
               c=a
               fa=fb
               fb=fc
               fc=fa
            end if
            tol1=2.0d0*eps*abs(b)+0.5d0*tol
            xm=0.5d0*(c-b)
            if (abs(xm) <= tol1 .or. fb == 0.0) then
               zbrent=b
               return
            end if
            !
            if (abs(e) >= tol1 .AND. abs(fa) > abs(fb)) then
               s=fb/fa
               if (a == c) then
                  p=2.0d0*xm*s
                  q=1.0d0-s
               else
                  q=fa/fc
                  r=fb/fc
                  p=s*(2.0d0*xm*q*(q-r)-(b-a)*(r-1.0d0))
                  q=(q-1.0d0)*(r-1.0d0)*(s-1.0d0)
               end if
               if (p > 0.0) q=-q
               p=abs(p)
               if (2.0d0*p  <  min(3.0d0*xm*q-abs(tol1*q),abs(e*q))) then
                  e=d
                  d=p/q
               else
                  d=xm
                  e=d
               end if
            else
               d=xm
               e=d
            end if
            a=b
            fa=fb
            b=b+merge(d,sign(tol1,xm), abs(d) > tol1 )
            fb=func(b,args)
         end do
         write(*,"(A)")'zbrent: exceeded maximum iterations'
         zbrent=b
       end function zbrent

       function zbrent_array(func,x1,x2,args,tol) result(zbrent)
         implicit none
         interface
            function func(x,args)
              implicit none
              real(8), intent(in), dimension(:) :: x
              real(8), intent(in), dimension(:,:) :: args
              real(8), dimension(size(x))       :: func
            end function func
         end interface
         real(8), intent(in), dimension(:,:) :: args
         real(8), intent(in), dimension(:) :: x1,x2
         real(8), intent(in) :: tol
         real(8), dimension(size(x1)) :: zbrent
         integer, parameter  :: itmax=100
         real(8), parameter  :: eps=epsilon(x1)
         integer             :: iter
         real(8), dimension(size(x1)) :: a,b,c,d,e,fa,fb,fc,p,q,r,s,xm,tol1
         logical, dimension(size(x1)) :: converge
!         real(8) :: tol1
         a=x1       ; b=x2
         fa=func(a,args) ; fb=func(b,args)
!         if ((fa > 0.0 .AND. fb > 0.0) .OR. (fa < 0.0 .AND. fb < 0.0))then
!            write(*,"(A)")'ROOT MUST BE BRACKETED FOR ZBRENT'
!            write(*,*) x1,x2,fa,fb
!            stop
!         endif
         c=b ; fc=fb
         do iter=1,itmax
            where((fb > 0d0 .AND. fc > 0d0) .OR. (fb < 0d0 .AND. fc < 0d0))
               c=a
               fc=fa
               d=b-a
               e=d
            endwhere
            where(abs(fc) < abs(fb))
               a=b
               b=c
               c=a
               fa=fb
               fb=fc
               fc=fa
            end where
            tol1=2.0d0*eps*abs(b)+0.5d0*tol
            xm=0.5d0*(c-b)
!            converge=(abs(xm).le.tol1.or.fb.eq.0d0)
!            if(count(converge).eq.size(xm)) return
!            where(converge) zbrent=b
            converge=(abs(xm) <= tol1 .or. fb == 0d0)
!            write(6,*) 'converge: ',converge,abs(xm)
! converged everywhere just return
! weird because you re-assign the converged results every iteration
! the python and IDL versions do this by indexing to keep track of absolute vs. new parts of arrays but don't know how to do that in fortran
! can probably do this without indexing separately by just recalculating nconverge each time and only assigning to zbrent for nconverge and not for converge
! TRY THAT
            where(converge)
               zbrent=b
            elsewhere
               where(abs(e) >= tol1 .AND. abs(fa) > abs(fb))
                  s=fb/fa
                  where(a == c)
                     p=2.0d0*xm*s
                     q=1.0d0-s
                  elsewhere
                     q=fa/fc
                     r=fb/fc
                     p=s*(2.0d0*xm*q*(q-r)-(b-a)*(r-1.0d0))
                     q=(q-1.0d0)*(r-1.0d0)*(s-1.0d0)
                  endwhere
                  where(p > 0d0)
                     q=-q
                  end where
                  p=abs(p)
                  where(2.0d0*p  <  min(3.0d0*xm*q-abs(tol1*q),abs(e*q)))
                     e=d
                     d=p/q
                  elsewhere
                     d=xm
                     e=d
                  endwhere
               elsewhere
                  d=xm
                  e=d
               end where
               a=b
               fa=fb
               b=b+merge(d,sign(tol1,xm), abs(d) > tol1 )
               fb=func(b,args)
            end where
            if (count(converge).eq.size(xm)) return
         end do
         write(*,"(A)")'zbrent: exceeded maximum iterations'
         zbrent=b
       end function zbrent_array

       end module math


      DOUBLE PRECISION FUNCTION iau_HD2PA ( HA, DEC, PHI )
*+
*  - - - - - - - - - -
*   i a u _ H D 2 P A
*  - - - - - - - - - -
*
*  Parallactic angle for a given hour angle and declination.
*
*  Given:
*     HA          d     hour angle
*     DEC         d     declination
*     PHI         d     site latitude
*
*  Returned:
*     iau_HD2PA   d     parallactic angle
*
*  Notes:
*
*  1)  All the arguments are angles in radians.
*
*  2)  The parallactic angle at a point in the sky is the position angle
*      of the vertical, i.e. the angle between the directions to the
*      north celestial pole and to the zenith respectively.
*
*  3)  The result is returned in the range -pi to +pi.
*
*  4)  At the pole itself a zero result is returned.
*
*  5)  The latitude PHI is pi/2 minus the angle between the Earth's
*      rotation axis and the adopted zenith.  In many applications it
*      will be sufficient to use the published geodetic latitude of the
*      site.  In very precise (sub-arcsecond) applications, PHI can be
*      corrected for polar motion.
*
*  6)  Should the user wish to work with respect to the astronomical
*      zenith rather than the geodetic zenith, PHI will need to be
*      adjusted for deflection of the vertical (often tens of
*      arcseconds), and the zero point of HA will also be affected.
*
*  Reference:
*     Smart, W.M., "Spherical Astronomy", Cambridge University Press,
*     6th edition (Green, 1977), p49.
*
*  This revision:   2017 September 12
*
*  SOFA release 2020-07-21
*
*  Copyright (C) 2020 IAU SOFA Board.  See notes at end.
*
*-----------------------------------------------------------------------

      IMPLICIT NONE

      DOUBLE PRECISION HA, DEC, PHI

      DOUBLE PRECISION CP, SQSZ, CQSZ

* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

      CP = COS(PHI)
      SQSZ = CP*SIN(HA)
      CQSZ = SIN(PHI)*COS(DEC) - CP*SIN(DEC)*COS(HA)
      IF ( SQSZ.EQ.0D0 .AND. CQSZ.EQ.0D0 ) CQSZ = 1D0
      iau_HD2PA = ATAN2(SQSZ,CQSZ)

*  Finished.

*+----------------------------------------------------------------------
*
*  Copyright (C) 2020
*  Standards Of Fundamental Astronomy Board
*  of the International Astronomical Union.
*
*  =====================
*  SOFA Software License
*  =====================
*
*  NOTICE TO USER:
*
*  BY USING THIS SOFTWARE YOU ACCEPT THE FOLLOWING SIX TERMS AND
*  CONDITIONS WHICH APPLY TO ITS USE.
*
*  1. The Software is owned by the IAU SOFA Board ("SOFA").
*
*  2. Permission is granted to anyone to use the SOFA software for any
*     purpose, including commercial applications, free of charge and
*     without payment of royalties, subject to the conditions and
*     restrictions listed below.
*
*  3. You (the user) may copy and distribute SOFA source code to others,
*     and use and adapt its code and algorithms in your own software,
*     on a world-wide, royalty-free basis.  That portion of your
*     distribution that does not consist of intact and unchanged copies
*     of SOFA source code files is a "derived work" that must comply
*     with the following requirements:
*
*     a) Your work shall be marked or carry a statement that it
*        (i) uses routines and computations derived by you from
*        software provided by SOFA under license to you; and
*        (ii) does not itself constitute software provided by and/or
*        endorsed by SOFA.
*
*     b) The source code of your derived work must contain descriptions
*        of how the derived work is based upon, contains and/or differs
*        from the original SOFA software.
*
*     c) The names of all routines in your derived work shall not
*        include the prefix "iau" or "sofa" or trivial modifications
*        thereof such as changes of case.
*
*     d) The origin of the SOFA components of your derived work must
*        not be misrepresented;  you must not claim that you wrote the
*        original software, nor file a patent application for SOFA
*        software or algorithms embedded in the SOFA software.
*
*     e) These requirements must be reproduced intact in any source
*        distribution and shall apply to anyone to whom you have
*        granted a further right to modify the source code of your
*        derived work.
*
*     Note that, as originally distributed, the SOFA software is
*     intended to be a definitive implementation of the IAU standards,
*     and consequently third-party modifications are discouraged.  All
*     variations, no matter how minor, must be explicitly marked as
*     such, as explained above.
*
*  4. You shall not cause the SOFA software to be brought into
*     disrepute, either by misuse, or use for inappropriate tasks, or
*     by inappropriate modification.
*
*  5. The SOFA software is provided "as is" and SOFA makes no warranty
*     as to its use or performance.   SOFA does not and cannot warrant
*     the performance or results which the user may obtain by using the
*     SOFA software.  SOFA makes no warranties, express or implied, as
*     to non-infringement of third party rights, merchantability, or
*     fitness for any particular purpose.  In no event will SOFA be
*     liable to the user for any consequential, incidental, or special
*     damages, including any lost profits or lost savings, even if a
*     SOFA representative has been advised of such damages, or for any
*     claim by any third party.
*
*  6. The provision of any version of the SOFA software under the terms
*     and conditions specified herein does not imply that future
*     versions will also be made available under the same terms and
*     conditions.
*
*  In any published work or commercial product which uses the SOFA
*  software directly, acknowledgement (see www.iausofa.org) is
*  appreciated.
*
*  Correspondence concerning SOFA software should be addressed as
*  follows:
*
*      By email:  sofa@ukho.gov.uk
*      By post:   IAU SOFA Center
*                 HM Nautical Almanac Office
*                 UK Hydrographic Office
*                 Admiralty Way, Taunton
*                 Somerset, TA1 2DN
*                 United Kingdom
*
*-----------------------------------------------------------------------

      END


  submodule (m_sort) m_heapsort
    !! Heapsort routines see https://rosettacode.org/wiki/Sorting_algorithms/Heapsort#Fortran
  use m_swap, only: swap

  implicit none

  contains
  !====================================================================!
  module procedure heapsort_r1D
  !====================================================================!
  integer(i32) :: start, bottom
  integer(i32) :: N
  N=size(this)
  do start =((n - 2) / 2), 0, -1
    call siftdown_r1D(this, start, n);
  end do
  do bottom = n-1 , 1, -1
    call swap(this(0),this(bottom))
    call siftdown_r1D(this, 0, bottom)
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  subroutine siftdown_r1D(this, start, bottom)
  !====================================================================!
  real(r32) :: this(0:)
  integer(i32) :: start
  integer(i32) :: bottom
  integer(i32) :: i,j
  i = start
  do while((i*2)+1 < bottom)
    j=(i*2)+1
    if (j + 1 < bottom) then
      if (this(j) < this(j+1)) j = j + 1
    end if
    if (this(i) < this(j)) then
      call swap(this(i), this(j))
      i = j
    else
      return
    end if
  end do
  end subroutine
  !====================================================================!
  !====================================================================!
  module procedure heapsort_d1D
  !====================================================================!
  integer(i32) :: start, bottom
  integer(i32) :: N
  N=size(this)
  do start =((n - 2) / 2), 0, -1
    call siftdown_d1D(this, start, n);
  end do
  do bottom = n-1 , 1, -1
    call swap(this(0),this(bottom))
    call siftdown_d1D(this, 0, bottom)
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  subroutine siftdown_d1D(this, start, bottom)
  !====================================================================!
  real(r64) :: this(0:)
  integer(i32) :: start
  integer(i32) :: bottom
  integer(i32) :: i,j
  i = start
  do while((i*2)+1 < bottom)
    j=(i*2)+1
    if (j + 1 < bottom) then
      if (this(j) < this(j+1)) j = j + 1
    end if
    if (this(i) < this(j)) then
      call swap(this(i), this(j))
      i = j
    else
      return
    end if
  end do
  end subroutine
  !====================================================================!
  !====================================================================!
  module procedure heapsort_i1D
  !====================================================================!
  integer(i32) :: start, bottom
  integer(i32) :: N
  N=size(this)
  do start =((n - 2) / 2), 0, -1
    call siftdown_i1D(this, start, n);
  end do
  do bottom = n-1 , 1, -1
    call swap(this(0),this(bottom))
    call siftdown_i1D(this, 0, bottom)
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  subroutine siftdown_i1D(this, start, bottom)
  !====================================================================!
  integer(i32) :: this(0:)
  integer(i32) :: start
  integer(i32) :: bottom
  integer(i32) :: i,j
  i = start
  do while((i*2)+1 < bottom)
    j=(i*2)+1
    if (j + 1 < bottom) then
      if (this(j) < this(j+1)) j = j + 1
    end if
    if (this(i) < this(j)) then
      call swap(this(i), this(j))
      i = j
    else
      return
    end if
  end do
  end subroutine
  !====================================================================!
  !====================================================================!
  module procedure heapsort_id1D
  !====================================================================!
  integer(i32) :: start, bottom
  integer(i32) :: N
  N=size(this)
  do start =((n - 2) / 2), 0, -1
    call siftdown_id1D(this, start, n);
  end do
  do bottom = n-1 , 1, -1
    call swap(this(0),this(bottom))
    call siftdown_id1D(this, 0, bottom)
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  subroutine siftdown_id1D(this, start, bottom)
  !====================================================================!
  integer(i64) :: this(0:)
  integer(i32) :: start
  integer(i32) :: bottom
  integer(i32) :: i,j
  i = start
  do while((i*2)+1 < bottom)
    j=(i*2)+1
    if (j + 1 < bottom) then
      if (this(j) < this(j+1)) j = j + 1
    end if
    if (this(i) < this(j)) then
      call swap(this(i), this(j))
      i = j
    else
      return
    end if
  end do
  end subroutine
  !====================================================================!
  !====================================================================!
  module procedure argHeapsort_r1D
  !====================================================================!
  integer(i32) :: start, bottom
  integer(i32) :: N
  N=size(indx)
  do start =((n - 2) / 2), 0, -1
    call argSiftdown_r1D(this, indx, start, n);
  end do
  do bottom = n-1 , 1, -1
    call swap(indx(0),indx(bottom))
    call argSiftdown_r1D(this, indx, 0, bottom)
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  subroutine argSiftdown_r1D(this, indx, start, bottom)
  !====================================================================!
  real(r32) :: this(:)
  integer(i32) :: indx(0:)
  integer(i32) :: start
  integer(i32) :: bottom
  integer(i32) :: i,j
  i = start
  do while((i*2)+1 < bottom)
    j=(i*2)+1
    if (j + 1 < bottom) then
      if (this(indx(j)) < this(indx(j+1))) j = j + 1
    end if
    if (this(indx(i)) < this(indx(j))) then
      call swap(indx(i), indx(j))
      i = j
    else
      return
    end if
  end do
  end subroutine
  !====================================================================!
  !====================================================================!
  module procedure argHeapsort_d1D
  !====================================================================!
  integer(i32) :: start, bottom
  integer(i32) :: N
  N=size(indx)
  do start =((n - 2) / 2), 0, -1
    call argSiftdown_d1D(this, indx, start, n);
  end do
  do bottom = n-1 , 1, -1
    call swap(indx(0),indx(bottom))
    call argSiftdown_d1D(this, indx, 0, bottom)
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  subroutine argSiftdown_d1D(this, indx, start, bottom)
  !====================================================================!
  real(r64) :: this(:)
  integer(i32) :: indx(0:)
  integer(i32) :: start
  integer(i32) :: bottom
  integer(i32) :: i,j
  i = start
  do while((i*2)+1 < bottom)
    j=(i*2)+1
    if (j + 1 < bottom) then
      if (this(indx(j)) < this(indx(j+1))) j = j + 1
    end if
    if (this(indx(i)) < this(indx(j))) then
      call swap(indx(i), indx(j))
      i = j
    else
      return
    end if
  end do
  end subroutine
  !====================================================================!
  !====================================================================!
  module procedure argHeapsort_i1D
  !====================================================================!
  integer(i32) :: start, bottom
  integer(i32) :: N
  N=size(indx)
  do start =((n - 2) / 2), 0, -1
    call argSiftdown_i1D(this, indx, start, n);
  end do
  do bottom = n-1 , 1, -1
    call swap(indx(0),indx(bottom))
    call argSiftdown_i1D(this, indx, 0, bottom)
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  subroutine argSiftdown_i1D(this, indx, start, bottom)
  !====================================================================!
  integer(i32) :: this(:)
  integer(i32) :: indx(0:)
  integer(i32) :: start
  integer(i32) :: bottom
  integer(i32) :: i,j
  i = start
  do while((i*2)+1 < bottom)
    j=(i*2)+1
    if (j + 1 < bottom) then
      if (this(indx(j)) < this(indx(j+1))) j = j + 1
    end if
    if (this(indx(i)) < this(indx(j))) then
      call swap(indx(i), indx(j))
      i = j
    else
      return
    end if
  end do
  end subroutine
  !====================================================================!
  !====================================================================!
  module procedure argHeapsort_id1D
  !====================================================================!
  integer(i32) :: start, bottom
  integer(i32) :: N
  N=size(indx)
  do start =((n - 2) / 2), 0, -1
    call argSiftdown_id1D(this, indx, start, n);
  end do
  do bottom = n-1 , 1, -1
    call swap(indx(0),indx(bottom))
    call argSiftdown_id1D(this, indx, 0, bottom)
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  subroutine argSiftdown_id1D(this, indx, start, bottom)
  !====================================================================!
  integer(i64) :: this(:)
  integer(i32) :: indx(0:)
  integer(i32) :: start
  integer(i32) :: bottom
  integer(i32) :: i,j
  i = start
  do while((i*2)+1 < bottom)
    j=(i*2)+1
    if (j + 1 < bottom) then
      if (this(indx(j)) < this(indx(j+1))) j = j + 1
    end if
    if (this(indx(i)) < this(indx(j))) then
      call swap(indx(i), indx(j))
      i = j
    else
      return
    end if
  end do
  end subroutine
  !====================================================================!
end submodule


use std
implicit none

type(IO_) :: f
integer(int32) :: num_sampling = 10000
real(real64),allocatable   :: t(:), Ft(:)

! from t=-100 ~ 100, 1000 sampling
t = linspace([0.0d0,4.0d0],num_sampling)

! create sampling wave
Ft = zeros(num_sampling)
Ft(:) = (1 - t*t)*exp(-t*t*0.50d0 )

call f%open("Ricker_wavelet.txt","w")
call f%write(t,Ft)
call f%close()

call f%plot("Ricker_wavelet.txt")

end


      DOUBLE PRECISION FUNCTION sla_DRANGE (ANGLE)
*+
*     - - - - - - -
*      D R A N G E
*     - - - - - - -
*
*  Normalize angle into range +/- pi  (double precision)
*
*  Given:
*     ANGLE     dp      the angle in radians
*
*  The result (double precision) is ANGLE expressed in the range +/- pi.
*
*  P.T.Wallace   Starlink   23 November 1995
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 59 Temple Place, Suite 330,
*    Boston, MA  02111-1307  USA
*
*-

      IMPLICIT NONE

      DOUBLE PRECISION ANGLE

      DOUBLE PRECISION DPI,D2PI
      PARAMETER (DPI=3.141592653589793238462643D0)
      PARAMETER (D2PI=6.283185307179586476925287D0)

      sla_DRANGE=MOD(ANGLE,D2PI)
      IF (ABS(sla_DRANGE).GE.DPI)
     :          sla_DRANGE=sla_DRANGE-SIGN(D2PI,ANGLE)

      END


      subroutine setupdata(nx, ny, nz, cx)
      complex*16 cx(1,1,1)
	real*8 tpi
c
      tpi=8.d0*datan(1.d0)

      do iz = 1, nz
       z = float(iz-1)*10.0/float(nz)-5.0
       do iy = 1, ny
        y = float(iy-1)*10.0/float(ny)-5.0
        do ix = 1, nx
          x = float(ix-1)*10.0/float(nx)-5.0
          tmp  = (sin(tpi*x)*sin(tpi*y)+1.)*exp(-z**2)
          cx(ix,iy, iz) = cmplx(tmp, tmp)
        enddo
       enddo
      enddo
      return
      end


SUBROUTINE solve_band(pb,work,loads)
!
! This subroutine performs Gaussian forward and back-substitution
! on the reduced unsymmetric band matrix pb.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::pb(:,:),work(:,:)
 REAL(iwp),INTENT(OUT)::loads(0:)
 INTEGER::iwp1,n,n1,i,iv,l,iq,iv1
 REAL(iwp)::s,pt5=0.5_iwp
 iwp1=(UBOUND(pb,2)-1)/2+1
 n=UBOUND(pb,1)
 iq=2*iwp1-1
 n1=n-1
 DO iv=1,n1
   i=INT(work(iwp1,iv)+pt5)
   IF(i/=iv)THEN
     s=loads(iv)
     loads(iv)=loads(i)
     loads(i)=s
   END IF
   l=iv+iwp1-1
   IF(l>n)l=n
   iv1=iv+1
   DO i=iv1,l
     loads(i)=loads(i)-work(i-iv,iv)*loads(iv)
   END DO
 END DO
 loads(n)=loads(n)/pb(n,1)
 iv=n-1
 DO WHILE(iv/=0)
   s=loads(iv)
   l=iq
   IF(iv+l-1>n)l=n-iv+1
   DO i=2,l
     s=s-pb(iv,i)*loads(iv+i-1)
     loads(iv)=s/pb(iv,1)
   END DO
 iv=iv-1
 END DO
RETURN
END SUBROUTINE solve_band


! Sample solution to the problem posed in Lab 12.

program main

    use omp_lib
    use random_util, only: init_random_seed

    implicit none
    integer :: seed, nthreads
    integer, parameter :: ntests = 7
    real (kind=8), allocatable :: x(:)
    real (kind=8) :: sum, count1, count4
    real (kind=8), dimension(ntests)  :: mean,q1,q4
    integer :: i,n,k

    !$ nthreads = 2
    !$ call omp_set_num_threads(nthreads)
    !$ print *, "Number of threads: ", nthreads

    print *, "input seed"
    read *, seed

    call init_random_seed(seed)

    print *, "      n          mean        quartile 1    quartile 4"
    do k=1,ntests
        n = 10**(k+1)
        allocate(x(n))
        call random_number(x)
        sum = 0.d0
        count1 = 0
        count4 = 0
        !$omp parallel do reduction(+:sum,count1,count4)
        do i=1,n
            sum = sum + x(i)
            if (x(i) < 0.25) then
                count1 = count1 + 1
                endif
            if (x(i) > 0.75) then
                count4 = count4 + 1
                endif
            enddo
        mean(k) = sum / float(n)
        q1(k) = count1 / float(n)
        q4(k) = count4 / float(n)
        deallocate(x)

        print 601, n,mean(k),q1(k),q4(k)
 601    format(i10,3f15.8)
        enddo

end program main


submodule(euler_interface_m) euler_prob_0037_m
    implicit none

contains

    module character(len=20) function euler0037()
        write (euler0037, "(i20)") ans(1000000_int64)
    end function euler0037

    integer(int64) function ans(n)
        use euler_primes_m, only: sieve_of_Eratosthenes
        implicit none
        integer(int64), intent(in) :: n
        integer(int64) :: i, isum, icount
        logical, allocatable :: is_prime(:)

        call sieve_of_Eratosthenes(n, is_prime)
        i = 10_int64
        isum = 0_int64
        icount = 0_int64

        do
            if (icount == 11_int64 .or. i == n) exit

            if (is_prime(i) .and. is_truncatable(i, is_prime)) then
                isum = isum + i
                icount = icount + 1_int64
            end if
            i = i + 1_int64
        end do

        ans = isum
    end function ans

    logical function is_truncatable(n, is_prime)
        integer(int64), intent(in) :: n
        logical, allocatable, intent(in) :: is_prime(:)

        is_truncatable = .false.
        if (is_left_truncatable(n, is_prime) .and. &
            is_right_truncatable(n, is_prime)) is_truncatable = .true.
    end function is_truncatable

    logical function is_left_truncatable(n, is_prime)
        integer(int64), intent(in) :: n
        logical, allocatable, intent(in) :: is_prime(:)
        integer(int64) :: tmp

        tmp = 10_int64
        do while (tmp < n)
            if (.not. is_prime(mod(n, tmp))) then
                is_left_truncatable = .false.
                return
            end if
            tmp = tmp*10_int64
        end do
        is_left_truncatable = .true.
    end function is_left_truncatable

    logical function is_right_truncatable(n, is_prime)
        integer(int64), intent(in) :: n
        logical, allocatable, intent(in) :: is_prime(:)
        integer(int64) :: tmp

        tmp = n
        do while (tmp > 0_int64)
            if (is_prime(tmp)) then
                tmp = tmp/10_int64
            else
                is_right_truncatable = .false.
                return
            end if
        end do
        is_right_truncatable = .true.
    end function is_right_truncatable

end submodule euler_prob_0037_m


module slf_ramps

  use iso_fortran_env, only: r64 => real64
  implicit none

contains

  !----------------------------------------------------------------------------!
  ! this is a linear ramp

  elemental function ramp1(i,n,y0) result(y)
    integer, intent(in) :: i,n
    real(r64), intent(in), optional :: y0
    real(r64) :: y
    y = merge(real(i) / n, 1.0, i .le. n)
    if (present(y0)) y = y0 + (1 - y0) * y
  end function

  !----------------------------------------------------------------------------!
  ! this is a very steep ramp, for later iterations

  elemental function ramp2(i,n,y0) result(y)
    integer, intent(in) :: i,n
    real(r64), intent(in), optional :: y0
    real(r64) :: t,y
    t = merge(real(i) / n, 1.0, i .le. n)
    y = t * (2 - t)
    if (present(y0)) y = y0 + (1 - y0) * y
  end function

  !----------------------------------------------------------------------------!
  ! this is a very smooth, s-shaped ramp
  ! slow convergence but good if we are away from the solution

  elemental function ramp3(i,n,y0) result(y)
    integer, intent(in) :: i,n
    real(r64), intent(in), optional :: y0
    real(r64) :: t,y
    t = merge(real(i) / n, 1.0, i .le. n)
    y = (3 - 2*t) * t**2
    if (present(y0)) y = y0 + (1 - y0) * y
  end function

  !----------------------------------------------------------------------------!
  ! this is a very smooth ramp where you can control the starting
  ! level as well as slope of the starting point. It may be applied
  ! for very unstable equations (A = 0, B = 0) or for a very quick
  ! convergence (A = 0.25, B = 1)

  elemental function ramp4(i,n,A,B) result(y)
    integer, intent(in) :: i,n
    real(r64), intent(in) :: A,B
    real(r64) :: x,y
    x = merge(real(i) / n, 1.0, i .le. n)
    y = A + (1 - A) * B * x           &
      + 3 * (A - 1) * (B - 2) * x**2  &
      - (A - 1) * (3*B - 8) * x**3    &
      + (A - 1) * (B - 3) * x**4
  end function

  !----------------------------------------------------------------------------!
  ! this ramp starts smoothly, rises rapidly, and then slowly saturates to 1

  elemental function ramp5(i,n) result(y)
    integer, intent(in) :: i,n
    real(r64) :: t,y
    t = merge(real(i) / n, 1.0, i .le. n)
    y = (3*t**2 - 8*t + 6) * t**2
  end function

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

end module slf_ramps


program normalize
    implicit none
    real, dimension(5) :: data = [ 3.1, -1.4, 2.8, 3.1, 9.2]

    print *, data
    call norm(data)
    print *, data
    print *, sum(data)

contains

    subroutine norm(array)
        implicit none
        real, dimension(:), intent(inout) :: array

        array = array/sum(array)
    end subroutine norm

end program normalize


program main

use euler

implicit none

        integer (int64) :: a, b, pa, pb;
        a = 5

        OUTER: &
        do while(.TRUE.)

                pa = a;
                call pent(pa);

                INNER: &
                do b = 5, a/2, 1

                        pb = b;
                        call pent(pb);

                        if(pentagonal(pa-pb) .AND. pentagonal(pb+pa)) then
                                exit OUTER;
                        endif

                end do INNER

                call inc(a, 1_int64);

        end do OUTER

        call printint(pa-pb);

contains

        pure subroutine pent(x)

                integer (int64), intent(inout) :: x;
                x = (3 * x**2 - x)/2;

        end subroutine pent

        ! Utilise the fact that we can test if a number is pentagonal or not by
        ! using: 24x + 1 == y;
        ! Where y is a perfect square. AND, for non generalised solutions of
        ! n >= 0, we also must qualify that (24x + 1)**0.5 % 6 == 5

        pure function pentagonal(x)

                integer (int64), intent(in) :: x;
                integer (int64) :: tmp;
                logical :: pentagonal;

                tmp = 24 * x + 1;

                pentagonal = (perfect_square(tmp) .AND. &
                        mod(int(sqrt(real(tmp))), 6) == 5)

        end function pentagonal

end program main


***********************************************************************
c	                  ORBEL_SCGET.F
***********************************************************************
*     PURPOSE:  Given an angle, efficiently compute sin and cos.
*
*        Input:
*             angle ==> angle in radians (real scalar)
*
*        Output:
*             sx    ==>  sin(angle)  (real scalar)
*             cx    ==>  cos(angle)  (real scalar)
*
*     ALGORITHM: Obvious from the code
*     REMARKS: The HP 700 series won't return correct answers for sin
*       and cos if the angle is bigger than 3e7. We first reduce it
*       to the range [0,2pi) and use the sqrt rather than cos (it's faster)
*       BE SURE THE ANGLE IS IN RADIANS - NOT DEGREES!
*     AUTHOR:  M. Duncan.
*     DATE WRITTEN:  May 6, 1992.
*     REVISIONS:
***********************************************************************

	subroutine orbel_scget(angle,sx,cx)

      include '../swift.inc'

c...  Inputs Only:
        real*8 angle

c...  Output:
	real*8 sx,cx

c... Internals:
	integer nper
	real*8 x
	real*8 PI3BY2
	parameter(PI3BY2 = 1.5d0*PI)

c----
c...  Executable code

        nper = angle/TWOPI
	x = angle - nper*TWOPI
	if(x.lt.0.d0) then
           x = x + TWOPI
        endif
	sx = sin(x)
	cx= sqrt(1.d0 - sx*sx)
	if( (x .gt. PIBY2) .and. (x .lt.PI3BY2)) then
           cx = -cx
        endif

	return
	end   ! orbel_scget
c-------------------------------------------------------------------


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! DESCRIPTION:                                                     !
! 'statmechprob' is a program that solves for a canonical ensemble !
! N-state problem. Specifically, it solves for <E> and C_v both as !
! functions of T for a single site, one body, 3-state three-state, !
! problem. The user enters any three energy values with the        !
! condition that <E> and C_v are >= zero. The program then creates !
! two arrays over a predetermined temperature range. These arrays  !
! will then be used to plot <E>(T) and C_v(T).                     !
!								   !
! AUTHOR INFO:                                                     !
! Author: Michael Conroy                                           !
! Email: sietekk@gmail.com                                         !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

program statmechprob
implicit none

!DECLARE VARIABLES
real :: E0, E1, E2 !Energy level values
real :: Tmax, Tmin !Max and min temperatures for Tarray
real :: dT !Interval change in temperature
real :: Z, Zderiv1, Zderiv2 !Partition function Z and its first and second derivatives (Z' and Z")
real :: beta !Inverse temperature; k_b = 1
integer, parameter :: n=1000 !Number of values to populate Tarray
real, dimension(n):: Tarray !Temp values across 'n' intervals
real, dimension(2,n) :: EavgData !Holds <E>(T) data
real, dimension(2,n) :: CvData !Holds C_v(T) data
integer :: i, j, k, l, m, nn !Indices for implicit and reg do loops for array assignments

!DATA ENTRY AND CREATION
!Entry
print *, 'Enter Tmin and then Tmax seperated by a comma or space: '
read *, Tmin, Tmax
print *, 'Enter E0, E1, and then E2 seperated by a comma or space: '
read *, E0, E1, E2
!Calculaton and array population
dT = (Tmax - Tmin)/(n)
print *, 'The temperature interval dT is: ', dT
Tarray(:) = (/( i*dT+Tmin, i=1,n )/)
print *, 'The temperature array Tarray is: ', Tarray
EavgData(1,:) = (/ (Tarray(j), j=1,n) /)
CvData(1,:) = (/ (Tarray(k), k=1,n) /)

!CALCULATE <E> AND C_v VALUES
do l = 1,n
	beta = 1.0 / Tarray(l) !Remember, k_b = 1 here
	Z = exp(-beta*E0) + exp(-beta*E1) + exp(-beta*E2)
	Zderiv1 = -( E0*exp(-beta*E0) + E1*exp(-beta*E1) + E2*exp(-beta*E2) )
	Zderiv2 = (E0**2.)*exp(-beta*E0) + (E1**2.)*exp(-beta*E1) + (E2**2.)*exp(-beta*E2)
	EavgData(2,l) = -(Zderiv1 / Z)
	CvData(2,l) = (1 / Tarray(l)**2) * ((Zderiv2 / Z) - (Zderiv1 / Z)**2.)
end do

!OUTPUT DATA TO SCREEN
!print *, 'Outputing <E> besides C_v now...'
!print *, EavgData
!print *, CvData

!SAVE DATA
!<E> data will be saved to its own file first
open(unit=99,file='eavg.data',status='replace')
	do m=1,n
		write(99,*) EavgData(1,m), ' ', EavgData(2,m)
	end do
close(unit=99)
print *, '<E> data has been saved!'

!C_v data will be saved to its own file first
open(unit=99,file='cv.data',status='replace')
	do nn=1,n
		write(99,*) CvData(1,nn), ' ', CvData(2,nn)
	end do
close(unit=99)
print *, 'C_v data has been saved!'

!GRAPH DATA
call system('gnuplot statmechprob.gnu')

!END OF PROGRAM
end program statmechprob


      DOUBLE PRECISION FUNCTION VNORM(X,Y)
      IMPLICIT REAL*8(A-H,O-Z)
C
C  NORMALIZE A 3-VECTOR.
C
C  VAR  DIM  TYPE  I/O  DESCRIPTION
C  ---  ---  ----  ---  -----------
C
C  X    3    R*8   I    INPUT VECTOR TO BE NORMALIZED.
C
C  Y    3    R*8   O    OUTPUT UNIT VECTOR = X/LENGTH(X)
C
C  VNORM  1  R*8   O    MAGNITUDE OF THE INPUT VECTOR, X.
C
C******************************************************************
C
C   CODED BY CHARLIE PETRUZZO. 4/81.
C    MODIFIED.......
C
C******************************************************************
C
      DIMENSION X(3),Y(3)
      R = DSQRT(X(1)**2 +X(2)**2 +X(3)**2)
      Y(1) = X(1)/R
      Y(2) = X(2)/R
      Y(3) = X(3)/R
      VNORM = R
      RETURN
      END


      PROGRAM xzroots
C     driver for routine zroots
      INTEGER M,M1
      PARAMETER(M=4,M1=M+1)
      INTEGER i
      COMPLEX a(M1),roots(M)
      LOGICAL polish
      DATA a/(0.0,2.0),(0.0,0.0),(-1.0,-2.0),(0.0,0.0),(1.0,0.0)/
      write(*,'(/1x,a)') 'Roots of the polynomial x^4-(1+2i)*x^2+2i'
      polish=.false.
      call zroots(a,M,roots,polish)
      write(*,'(/1x,a)') 'Unpolished roots:'
      write(*,'(1x,t10,a,t25,a,t37,a)') 'Root #','Real','Imag.'
      do 11 i=1,M
        write(*,'(1x,i11,5x,2f12.6)') i,roots(i)
11    continue
      write(*,'(/1x,a)') 'Corrupted roots:'
      do 12 i=1,M
        roots(i)=roots(i)*(1.0+0.01*i)
12    continue
      write(*,'(1x,t10,a,t25,a,t37,a)') 'Root #','Real','Imag.'
      do 13 i=1,M
        write(*,'(1x,i11,5x,2f12.6)') i,roots(i)
13    continue
      polish=.true.
      call zroots(a,M,roots,polish)
      write(*,'(/1x,a)') 'Polished roots:'
      write(*,'(1x,t10,a,t25,a,t37,a)') 'Root #','Real','Imag.'
      do 14 i=1,M
        write(*,'(1x,i11,5x,2f12.6)') i,roots(i)
14    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xzroots.for


program multiplication
use routines
implicit none

real(kind=8), dimension(3) :: U, V, W

!exercise 3 - a:
   write(*,*) "exercise 3 - a:"
   V = (/1, 2, 3/)
   write(*,'(A8,5F8.3)') "V: ", V
   U = (/3, 2, 1/)
   write(*,'(A8,5F8.3)') "U: ", U
   W = cross(V, U)
   write(*,'(A8,5F8.3)') "W: ", W
   write(*,*)

!exercise 3 - b:
   write(*,*) "exercise 3 - b:"
   V = (/-2, 1, -3/)
   write(*,'(A8,5F8.3)') "V: ", V
   U = (/1, 1, 1/)
   write(*,'(A8,5F8.3)') "U: ", U
   W = cross(V, U)
   write(*,'(A8,5F8.3)') "W: ", W

end program multiplication


!--------------------------------------------------------------------------------------
!
!Copyright (C) 2014 TopCoder Inc., All Rights Reserved.
!
!--------------------------------------------------------------------------------------

!   This module computes utility for numerical integration and derivation of functions
!   Currently the romberg integration algorithm is implemented
!   and the Derivative by center differences/Richardson extrapolation is implemented
!   They work for real function or complex function of real parameter
!
! Contest Drift forces and QTF Implementation of Nemoh
!
! Changes in version 1.1 (Implementation of Higher Order Panel Methods)
!       Added COMMON_TYPE module as dependency

! Changes in version 1.2 (Dipoles Implementation in NEMOH)
!       Switch from ParamsCommon to ParamsCommonInf and added COMPUTE_NEXP subroutine
!
!   @author yedtoss
!   @version 1.2

module UTILITY
    USE COMMON_TYPE
    implicit none

contains

    SUBROUTINE trapzd(func,a,b,s,n,param)
        INTEGER n
        REAL a,b,s,func
        EXTERNAL func
        INTEGER it,j
        REAL del,sum,tnm,x
        TYPE(ParamsCommonInf) :: param
        if (n.eq.1) then
            s=0.5*(b-a)*(func(a, param)+func(b, param))
        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, param)
                x=x+del
            end do
            s=0.5*(s+(b-a)*sum/tnm)
        endif
        return
    END SUBROUTINE trapzd

    FUNCTION qtrap(func,a,b, param)
        INTEGER JMAX
        REAL a,b,func,qtrap,EPS
        EXTERNAL func
        PARAMETER (EPS=1.e-6, JMAX=20)
        TYPE(ParamsCommonInf) :: param
        INTEGER j
        REAL olds
        olds=-1.e30
        do j=1,JMAX
            call trapzd(func,a,b,qtrap,j, param)
            if (abs(qtrap-olds).lt.EPS*abs(olds)) return
            if (qtrap.eq.0..and.olds.eq.0..and.j.gt.6) return
            olds=qtrap
        end do
    !pause 'too many steps in qtrap'
    END FUNCTION qtrap

    SUBROUTINE trapzdc(func,a,b,s,n, param)
        INTEGER n
        REAL a,b
        COMPLEX func, sum, s
        EXTERNAL func
        INTEGER it,j
        REAL del,tnm,x
        TYPE(ParamsCommonInf) :: param
        COMPLEX,PARAMETER :: II=CMPLX(0.,1.)
        COMPLEX,PARAMETER :: ZERO=CMPLX(0.,0.)
        if (n.eq.1) then
            s=0.5*(b-a)*(func(a, param)+func(b, param))
        else
            it=2**(n-2)
            tnm=it
            del=(b-a)/tnm
            x=a+0.5*del
            sum=zero
            do j=1,it
                sum=sum+func(x, param)
                x=x+del
            end do
            s=0.5*(s+(b-a)*sum/tnm)
        endif
        return
    END SUBROUTINE trapzdc

    FUNCTION qtrapc(func,a,b, param)
        INTEGER JMAX
        REAL a,b,EPS
        COMPLEX qtrapc, func
        EXTERNAL func
        PARAMETER (EPS=1.e-6, JMAX=20)
        INTEGER j
        COMPLEX olds
        TYPE(ParamsCommonInf) :: param
        COMPLEX,PARAMETER :: II=CMPLX(0.,1.)
        COMPLEX,PARAMETER :: ZERO=CMPLX(0.,0.)
        olds=zero
        do j=1,JMAX
            call trapzdc(func,a,b,qtrapc,j, param)
            if (abs(qtrapc-olds).lt.EPS*abs(olds)) return
            if (qtrapc.eq.0..and.olds.eq.0..and.j.gt.6) return
            olds=qtrapc
        end do
    !pause 'too many steps in qtrap'
    END FUNCTION qtrapc

    real function deriv_richardson(f,x,n,h_ini, param)
        integer, intent(in) :: n
        real, dimension (0:n,0:n) :: d
        real, intent(in) :: x
        real :: q, h_ini, h
        integer :: i, j
        real, external :: f
        TYPE(ParamsCommonInf) :: param

        h = h_ini

        do  i=0,n
            d(i,0)=(f(x+h, param)-f(x-h, param))/(2.0*h)
            q=4.0
            do  j=0,i-1
                d(i,j+1)=d(i,j)+(d(i,j)-d(i-1,j))/(q-1.0)
                deriv_richardson = d(i,j+1)
                q=4.0*q
            end do
            h=h/2.0
        end do
    end function deriv_richardson

    complex function deriv_richardson_complex(f,x,n,h_ini, param)
        integer, intent(in) :: n
        complex, dimension (0:n,0:n) :: d
        real, intent(in) :: x
        real :: q, h, h_ini
        integer :: i, j
        complex, external :: f
        TYPE(ParamsCommonInf) :: param

        h = h_ini

        do  i=0,n
            d(i,0)=(f(x+h, param)-f(x-h, param))/(2.0*h)
            q=4.0
            do  j=0,i-1
                d(i,j+1)=d(i,j)+(d(i,j)-d(i-1,j))/(q-1.0)
                deriv_richardson_complex = d(i,j+1)
                q=4.0*q
            end do
            h=h/2.0
        end do
    end function deriv_richardson_complex

    function romberg_trap ( f, a, b, tol, maxM, param )

        !*****************************************************************************80
        !
        !! ROMBERG_TRAP approximates an integral by extrapolating the trapezoidal rule.
        !
        !  Discussion:
        !
        !    This routine computes a sequence of integral estimates involving the
        !    trapezoid rule.  Extrapolation of successive trapezoidal estimates
        !    produces an estimate with a higher rate of convergence.
        !
        !  Licensing:
        !
        !    This code is distributed under the GNU LGPL license.
        !
        !  Modified:
        !
        !    28 February 2013
        !
        !  Author:
        !
        !    John Burkardt
        !
        !  Parameters:
        !
        !    Input, real  A, B, the endpoints of the interval.
        !
        !    Input, external real  F, the name of the function
        !    which evaluates the integrand, and whose form is:
        !      function f ( x )
        !      real  f
        !      real  x
        !      f = ...
        !
        !    Input, real  TOL, the tolerance.  When two successive integral
        !    estimates differ by less than this value, the iteration will halt.
        !
        !    Output, integer  M, the number of trapezoidal estimates
        !    that were required.
        !
        !    Output, real  ROMBERG_TRAP, the integral estimate.
        !
        implicit none

        real  a
        real b
        !real , external :: f
        integer  m, maxM
        real  q
        real  q_new
        real  r
        real  r_new
        real  romberg_trap
        real  tol
        !real  trapezoid_refine
        TYPE(ParamsCommonInf) :: param

        interface

            real function f(theta, param)

                USE COM_VAR
                TYPE(ParamsCommonInf) :: param
                REAL, INTENT(IN) :: theta

            end function f

        end interface

        q_new = 0.0D+00
        r_new = 0.0D+00
        m = 1

        do

            q = q_new
            q_new = trapezoid_refine ( a, b, m, f, q, param )

            if ( m == 1 ) then
                r_new = q_new
            else
                r = r_new
                r_new = ( 4.0D+00 * q_new - q ) / 3.0D+00
                if ( abs ( r_new - r ) .lt. tol * ( 1.0 + abs ( r_new ) ) ) then
                    exit
                end if
            end if

            if ( maxM <= m ) then
                !write ( *, '(a)' ) ' '
                !write ( *, '(a)' ) 'ROMBERG_TRAP!'
                !write ( *, '(a)' ) '  No convergence in 20 iterations.'
                !write ( *, '(a)' ) '  The algorithm is halting.'
                return
            end if

            m = m + 1

        end do

        romberg_trap = r_new

        return
    end function romberg_trap

    function trapezoid_refine ( a, b, m, f, q, param)

        !*****************************************************************************80
        !
        !! TRAPEZOID_REFINE carries out a step of trapezoidal refinement.
        !
        !  Discussion:
        !
        !    This routine is designed to be an efficient way to carry out a
        !    sequence of integral estimates, using the trapezoidal rule
        !    and a nested sequence of evaluation points, in such a way that
        !    the function is not re-evaluated unnecessarily.
        !
        !    The user calls first with M = 1 and Q = 0 to get a 2 point
        !    integral estimate.  On the second call, the user sets M = 2,
        !    and the input value of Q should be the integral estimate returned
        !    on the previous call.  By incrementing M and passing the previous
        !    estimate, the user gets a sequence of increasingly improved
        !    integral estimates:
        !
        !    q = 0.0
        !    m = 1
        !    do
        !      q_new = trapezoid_refine ( a, b, m, f, q )
        !      if ( satisfied ) then
        !        exit
        !      end if
        !      q = q_new
        !      m = m + 1
        !    end do
        !
        !    The number of points used on each step of the iteration is:
        !
        !    M   N
        !    1   2
        !    2   3
        !    3   5
        !    4   9
        !    5  17
        !    6  33
        !    m   2^(m-1)+1
        !
        !  Licensing:
        !
        !    This code is distributed under the GNU LGPL license.
        !
        !  Modified:
        !
        !    27 February 2013
        !
        !  Author:
        !
        !    John Burkardt
        !
        !  Parameters:
        !
        !    Input, real  A, B, the endpoints of the interval.
        !
        !    Input, integer  M, the current level of refinement.
        !    On the first call, M should be 1.  On each subsequent call,
        !    the user should increment M by 1.
        !
        !    Input, external real  F, the name of the function
        !    which evaluates the integrand, and whose form is:
        !      function f ( x )
        !      real  f
        !      real  x
        !      f = ...
        !
        !    Input, real  Q, the integral estimate return on
        !    the previous call.  But on the first call, set Q to zero.
        !
        !    Output, real  TRAPEZOID_REFINE, the improved
        !    integral estimate.
        !
        implicit none

        real  a
        real b
        !real , external :: f
        integer  i
        integer k
        integer  m
        real  q
        real  trapezoid_refine
        real  value
        real  x
        TYPE(ParamsCommonInf) :: param

        interface

            real function f(theta, param)

                USE COM_VAR
                TYPE(ParamsCommonInf) :: param
                REAL, INTENT(IN) :: theta

            end function f

        end interface

        if ( m < 1 ) then

            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'TRAPEZOID_REFINE - Fatal error!'
            write ( *, '(a)' ) '  Illegal input value of M.'
            stop

        else if ( m == 1 ) then

            value = ( b - a ) / 2.0D+00 * ( f ( a, param ) + f ( b, param ) )

        else if ( 2 <= m ) then

            k = 2 ** ( m - 2 )
            value = 0.0D+00
            do i = 1, k
                x = ( real ( 2 * k - 2 * i + 1 ) * a   &
                    + real (         2 * i - 1 ) * b ) &
                    / real ( 2 * k )
                value = value + f ( x, param )
            end do

            value = 0.5D+00 * q + ( b - a ) * value / real ( 2 * k )

        end if

        trapezoid_refine = value

        return
    end function trapezoid_refine

    complex function romberg_trap_complex ( f, a, b, tol, maxM, param )

        !*****************************************************************************80
        !
        !! ROMBERG_TRAP approximates an integral by extrapolating the trapezoidal rule.
        !
        !  Discussion:
        !
        !    This routine computes a sequence of integral estimates involving the
        !    trapezoid rule.  Extrapolation of successive trapezoidal estimates
        !    produces an estimate with a higher rate of convergence.
        !
        !  Licensing:
        !
        !    This code is distributed under the GNU LGPL license.
        !
        !  Modified:
        !
        !    28 February 2013
        !
        !  Author:
        !
        !    John Burkardt
        !
        !  Parameters:
        !
        !    Input, real  A, B, the endpoints of the interval.
        !
        !    Input, external real  F, the name of the function
        !    which evaluates the integrand, and whose form is:
        !      function f ( x )
        !      real  f
        !      real  x
        !      f = ...
        !
        !    Input, real  TOL, the tolerance.  When two successive integral
        !    estimates differ by less than this value, the iteration will halt.
        !
        !    Output, integer  M, the number of trapezoidal estimates
        !    that were required.
        !
        !    Output, real  ROMBERG_TRAP, the integral estimate.
        !
        implicit none

        real  a
        real  b
        complex, external :: f
        integer  m, maxM
        complex q
        complex q_new
        complex r
        complex r_new
        real  tol
        TYPE(ParamsCommonInf) :: param
        COMPLEX,PARAMETER :: ZERO=CMPLX(0.,0.)

        q_new = ZERO
        r_new = ZERO
        m = 1

        do

            q = q_new
            q_new = trapezoid_refine_complex ( a, b, m, f, q, param )

            if ( m == 1 ) then
                r_new = q_new
            else
                r = r_new
                r_new = ( 4.0D+00 * q_new - q ) / 3.0D+00
                if ( abs ( r_new - r ) .lt. tol * ( 1.0 + abs ( r_new ) ) ) then
                    exit
                end if
            end if

            if ( maxM <= m ) then
                !write ( *, '(a)' ) ' '
                !write ( *, '(a)' ) 'ROMBERG_TRAP!'
                !write ( *, '(a)' ) '  No convergence in 20 iterations.'
                !write ( *, '(a)' ) '  The algorithm is halting.'
                return
            end if

            m = m + 1

        end do

        romberg_trap_complex = r_new

        return
    end function romberg_trap_complex

    complex function trapezoid_refine_complex ( a, b, m, f, q, param)

        !*****************************************************************************80
        !
        !! TRAPEZOID_REFINE carries out a step of trapezoidal refinement.
        !
        !  Discussion:
        !
        !    This routine is designed to be an efficient way to carry out a
        !    sequence of integral estimates, using the trapezoidal rule
        !    and a nested sequence of evaluation points, in such a way that
        !    the function is not re-evaluated unnecessarily.
        !
        !    The user calls first with M = 1 and Q = 0 to get a 2 point
        !    integral estimate.  On the second call, the user sets M = 2,
        !    and the input value of Q should be the integral estimate returned
        !    on the previous call.  By incrementing M and passing the previous
        !    estimate, the user gets a sequence of increasingly improved
        !    integral estimates:
        !
        !    q = 0.0
        !    m = 1
        !    do
        !      q_new = trapezoid_refine ( a, b, m, f, q )
        !      if ( satisfied ) then
        !        exit
        !      end if
        !      q = q_new
        !      m = m + 1
        !    end do
        !
        !    The number of points used on each step of the iteration is:
        !
        !    M   N
        !    1   2
        !    2   3
        !    3   5
        !    4   9
        !    5  17
        !    6  33
        !    m   2^(m-1)+1
        !
        !  Licensing:
        !
        !    This code is distributed under the GNU LGPL license.
        !
        !  Modified:
        !
        !    27 February 2013
        !
        !  Author:
        !
        !    John Burkardt
        !
        !  Parameters:
        !
        !    Input, real  A, B, the endpoints of the interval.
        !
        !    Input, integer  M, the current level of refinement.
        !    On the first call, M should be 1.  On each subsequent call,
        !    the user should increment M by 1.
        !
        !    Input, external real  F, the name of the function
        !    which evaluates the integrand, and whose form is:
        !      function f ( x )
        !      real  f
        !      real  x
        !      f = ...
        !
        !    Input, real  Q, the integral estimate return on
        !    the previous call.  But on the first call, set Q to zero.
        !
        !    Output, real  TRAPEZOID_REFINE, the improved
        !    integral estimate.
        !
        implicit none

        real  a
        real  b
        complex, external :: f
        integer  i
        integer  k
        integer  m
        complex q
        complex value
        real  x
        TYPE(ParamsCommonInf) :: param
        COMPLEX,PARAMETER :: ZERO=CMPLX(0.,0.)

        if ( m < 1 ) then

            write ( *, '(a)' ) ' '
            write ( *, '(a)' ) 'TRAPEZOID_REFINE - Fatal error!'
            write ( *, '(a)' ) '  Illegal input value of M.'
            stop

        else if ( m == 1 ) then

            value = ( b - a ) / 2.0D+00 * ( f ( a, param ) + f ( b, param ) )

        else if ( 2 <= m ) then

            k = 2 ** ( m - 2 )
            value = ZERO
            do i = 1, k
                x = ( real ( 2 * k - 2 * i + 1) * a   &
                    + real (         2 * i - 1) * b ) &
                    / real ( 2 * k)
                value = value + f ( x, param )
            end do

            value = 0.5D+00 * q + ( b - a ) * value / real ( 2 * k)

        end if

        trapezoid_refine_complex = value

        return
    end function trapezoid_refine_complex

    SUBROUTINE COMPUTE_NEXP(param)
    ! This is a utility to compute precompute values needed to integrate green function
    ! and to compute next
    ! param: common variables that contains useful variables
    !        See param definition for explanation of the member used here

    USE COMPUTE_GREEN_FD
    USE COMPUTE_GREEN_INFD
    USE COM_VAR

        REAL:: GM, BJ, DIJ, AKK
        TYPE(ParamsCommonInf), TARGET :: param
        INTEGER:: NP1, N,  JJ, I, J, I1, NJJ
        INTEGER, POINTER:: NQ
        REAL, POINTER:: CQ(:),QQ(:),AMBDA(:),AR(:)
        REAL, POINTER :: FSP,FSM,VSXP,VSYP,VSZP,VSXM,VSYM,VSZM
        TYPE(TempVar), POINTER :: SolverVar

        SolverVar => param%SolverVar

        AMBDA => SolverVar%AMBDA
        AR => SolverVar%AR
        NQ => SolverVar%NQ
        CQ => SolverVar%CQ
        QQ => SolverVar%QQ
        VSXP => SolverVar%VSXP
        VSYP => SolverVar%VSYP
        VSZP => SolverVar%VSZP
        VSXM => SolverVar%VSXM
        VSYM => SolverVar%VSYM
        VSZM => SolverVar%VSZM

         !--------------Initilizations---------------
        VSXP=0.
        VSXM=0.
        VSYP=0.
        VSYM=0.
        VSZP=0.
        VSZM=0.
        !--------------------------------------------

        NJJ=NSYMY+1

        IF(ProblemSavedAt(SolverVar%ProblemNumber) < 0 ) THEN
            CQ=0.0
            QQ=0.0
            AMBDA=0.0
            AR=0.0

            GM=0.
            NP1=NP-1
            DO I=1,NP1
                I1=I+1
                DO JJ=1,NJJ
                    BJ=(-1.)**(JJ+1)
                    DO J=I1,NP
                        DIJ=SQRT((X(J)-X(I))**2+(Y(I)-Y(J)*BJ)**2)
                        GM=MAX(DIJ,GM)
                    END DO
                END DO
            END DO
            AKK=param%AM0*GM

        END IF

        IF(param%is_infinite == 1) THEN

            IF(ProblemSavedAt(SolverVar%ProblemNumber) < 0 ) THEN

                CALL CINT_INFD(AKK,N, SolverVar)
                !N=NQ Bug Fixes
                NQ = N
                IF(ProblemSavedAt(SolverVar%ProblemNumber) == -1 ) THEN
                    DO I=1,101
                        CQCache(ProblemToSaveLocation(SolverVar%ProblemNumber), I)  = CQ(I)
                        QQCache(ProblemToSaveLocation(SolverVar%ProblemNumber), I) =  QQ(I)
                    END DO

                END IF

            ELSE

                DO I=1,101
                    CQ(I) = CQCache(ProblemSavedAt(SolverVar%ProblemNumber), I)
                    QQ(I) = QQCache(ProblemSavedAt(SolverVar%ProblemNumber), I)
                END DO

            END IF

        ELSE
            IF(ProblemSavedAt(SolverVar%ProblemNumber) < 0 ) THEN

                CALL CINT_FD(AKK,N)
                !N=NQ Bug Fixes
                NQ = N
                CALL LISC(param%AKH,param%AMH,param%NEXP, SolverVar)

                IF(ProblemSavedAt(SolverVar%ProblemNumber) == -1 ) THEN
                    DO I=1,31
                        ARCache(ProblemToSaveLocation(SolverVar%ProblemNumber), I)  = AR(I)
                        AMBDACache(ProblemToSaveLocation(SolverVar%ProblemNumber), I) =  AMBDA(I)

                    END DO
                    NEXPCache(ProblemToSaveLocation(SolverVar%ProblemNumber)) = param%NEXP

                END IF

            ELSE

                DO I=1,31
                    AR(I) = ARCache(ProblemSavedAt(SolverVar%ProblemNumber), I)
                    AMBDA(I) = AMBDACache(ProblemSavedAt(SolverVar%ProblemNumber), I)
                END DO

                param%NEXP = NEXPCache(ProblemSavedAt(SolverVar%ProblemNumber))

            END IF

        END IF

    END SUBROUTINE COMPUTE_NEXP

end module UTILITY


        integer function sigprod(n)
        integer n, i
        double precision s, w
        s = 1.0
        w = 1.0
        do 10, i=1, n
           w = w / i
           s = s + w
   10   continue
        sigprod = s
        end

        double precision function ff2(n)
        integer n, i, fact
        double precision sum1
        sum1 = 0.0
        fact = 1.0
        do 60, i=1, n
           fact = fact * i
           sum1 = sum1 + 1/fact
   60   continue
        ff2 = sum1
        end

        integer function sigsum(n)
        integer n, i
        double precision s, w
        s = 1.0
        w = 1.0
        do 20, i=1, n
           w = w * i
           s = s + w
   20   continue
        sigsum = s
        end

        integer function sigsum1(n)
        integer n, i, s
        s=n
        do 30, i=n-1, 1, -1
           s = i * (1 + s)
   30   continue
        sigsum = s+1
        end

        integer function chebyshev(n,x)
        integer n, x, i, u0, u1, v
        u0 = 1
        u1 = x
        do 50, i=2, n
           v = u1
           u1 = -u0 + 2*x*u1
           u0 = v
   50   continue
        chebyshev = u1
        end

        double precision function bessel(z, nu, m)
        integer i, z, nu, m
        double precision res, u
        res = 0
        u = 1
        do 40, i=0, m-1
           res = res + u
           u = -u*z**2 / (4*(i+nu+1)*(i+1))
   40   continue
        bessel = res
        end

        double precision function mystery(z, nu, m)
        integer z, nu, m, i
        double precision res, t
        res = 0
        t = 1
        do 70, i=0, m
           res = res + t
           t = -t*z**2 / (4*(i+nu+1)*(i+1))
   70   continue
        mystery = res
        end


!--------------------------------------------------------------------------------
! Copyright (c) 2017 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      MODULE m_difcub

      CONTAINS

      REAL FUNCTION difcub(x,f,xi)
c     **********************************************************
c     differentiate the function f, given at the
c     points x0,x1,x2,x3 at the point xi by lagrange
c     interpolation for polynomial of 3rd order
c     r.p.
c     ***********************************************************
      IMPLICIT NONE
C     .. Scalar Arguments ..
      REAL xi
C     ..
C     .. Array Arguments ..
      REAL f(0:3),x(0:3)
C     ..
      difcub = ((xi-x(1))* (xi-x(2))+ (xi-x(1))* (xi-x(3))+
     +         (xi-x(2))* (xi-x(3)))*f(0)/ ((x(0)-x(1))* (x(0)-x(2))*
     +         (x(0)-x(3))) + ((xi-x(0))* (xi-x(2))+
     +         (xi-x(0))* (xi-x(3))+ (xi-x(2))* (xi-x(3)))*f(1)/
     +         ((x(1)-x(0))* (x(1)-x(2))* (x(1)-x(3))) +
     +         ((xi-x(0))* (xi-x(1))+ (xi-x(0))* (xi-x(3))+
     +         (xi-x(1))* (xi-x(3)))*f(2)/ ((x(2)-x(0))* (x(2)-x(1))*
     +         (x(2)-x(3))) + ((xi-x(0))* (xi-x(1))+
     +         (xi-x(0))* (xi-x(2))+ (xi-x(1))* (xi-x(2)))*f(3)/
     +         ((x(3)-x(0))* (x(3)-x(1))* (x(3)-x(2)))
      RETURN
      END FUNCTION difcub

      END MODULE m_difcub


!Autor: Claudio Iván Esparza Castañeda
!Título: Punto Fijo (Sistema)
!Descripción: Permite encontrar las raíces de un sistema de ecuaciones no lineales por el método del punto fijo
!Fecha: 18/03/2020

Program bis
  implicit none
  REAL::e, er, x, y, x0, y0, xe, f, g
  INTEGER::i
  WRITE(*, *) "Valor inicial" !Preguntar valor inicial
  READ(*, *) x0 !Ingresar valor inicial
  WRITE(*, *) "Valor inicial" !Preguntar valor inicial
  READ(*, *) y0 !Ingresar valor inicial
  WRITE(*, *) "Error esperado" !Preguntar el error
  READ(*, *) er !Ingresar el error
  x=x0 !Inicializar x
  y=y0 !Inicializar y
  i=0 !Inicializar contador de ciclos
  do
     i=i+1 !Añadir uno al contador
     xe=x !Asignar x anterior
     x=f(x, y)
     y=g(x, y)
     if (x .NE. 0) then !Validación del intervalo
        e=abs((x-xe)/x)*100 !Cálculo del error
     end if
     if (e<er) then !Validar si el error es menor al esperado
        EXIT
     end if
  end do
  write(*, *) "       x              y                 e               i" !Cabecera del resultado
  write(*, *) x, y, e, i !Imprimir resultado
end Program bis

function f(x, y) !Función original
  implicit none
  REAL::f, x, y
  f=sqrt(10-x*y)
end function f

function g(x, y) !Función con despeje
  implicit none
  REAL::g, x, y
  g=sqrt((57-y)/(3*x))
end function g


program compute_trace
    implicit none
    integer :: i
    real, dimension(5, 5) :: A

    call random_number(A)
    do i = 1, size(A, 1)
        print '(5F7.4)', A(i, :)
    end do
    print '(/, A, F7.4)', 'trace = ', trace(A)

contains

    real function trace(matrix)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        real, dimension(:, :), intent(in) :: matrix
        integer :: i

        if (size(matrix, 1) /= size(matrix, 2)) then
            write (unit=error_unit, fmt='(A)') &
                'error: can not compute trace of a non-square matrix'
            stop 1
        end if
        trace = 0.0
        do i = 1, size(matrix, 1)
            trace = trace + matrix(i, i)
        end do
    end function trace

end program compute_trace


! RUN: %python %S/test_folding.py %s %flang_fc1
! Tests folding of integer and real MOD and MODULO
module m1
  logical, parameter :: test_mod_i1 = mod(8, 5) == 3
  logical, parameter :: test_mod_i2 = mod(-8, 5) == -3
  logical, parameter :: test_mod_i3 = mod(8, -5) == 3
  logical, parameter :: test_mod_i4 = mod(-8, -5) == -3

  logical, parameter :: test_mod_r1 = mod(3., 2.) == 1.
  logical, parameter :: test_mod_r2 = mod(8., 5.) == 3.
  logical, parameter :: test_mod_r3 = mod(-8., 5.) == -3.
  logical, parameter :: test_mod_r4 = mod(8., -5.) == 3.
  logical, parameter :: test_mod_r5 = mod(-8., -5.) == -3.

  logical, parameter :: test_modulo_i1 = modulo(8, 5) == 3
  logical, parameter :: test_modulo_i2 = modulo(-8, 5) == 2
  logical, parameter :: test_modulo_i3 = modulo(8, -5) == -2
  logical, parameter :: test_modulo_i4 = modulo(-8, -5) == -3

  logical, parameter :: test_modulo_r1 = modulo(8., 5.) == 3.
  logical, parameter :: test_modulo_r2 = modulo(-8., 5.) == 2.
  logical, parameter :: test_modulo_r3 = modulo(8., -5.) == -2.
  logical, parameter :: test_modulo_r4 = modulo(-8., -5.) == -3.
end module


! ****************************************************************************
! ... rk.f90
! ... Runge-Kutta routines
! ... COSMO Project
! ... Quim Ballabrera, March 2017
! ****************************************************************************

module runge_kutta

use types, only: dp

implicit none
private
public rk1,rk2,rk3,rk4,rk5

contains
! ...
! =============================================================================
! ...
subroutine rk1 (n,x,t,h,xn,RHS)

! ... Given values for the variables x(1:n) and a function, RHS, returning
! ... its derivatives dxdt(1:n), a first-order Runge-Kutta (Euler) method
! ... is used to advance the solution over an interval h and return the
! ... incremented variable as xn(1:n).
! ... The user must supply the subroutine RHS(t,x,dxdt) returning
! ... derivatives dxdt at t.

integer, intent(in)                  :: n
real(dp), intent(in)                 :: t,h
real(dp), dimension(n), intent(in)   :: x
real(dp), dimension(n), intent(out)  :: xn
EXTERNAL                             :: RHS

! ... Local variables
! ...
real(dp), dimension(n)               :: k1

CALL RHS(n,t,x,k1)
k1 = h*k1

xn(:) = x(:) + k1(:)

return
end subroutine rk1
! ...
! =============================================================================
! ...
subroutine rk2 (n,x,t,h,xn,RHS)

! ... Given values for the variables x(1:n) and a function, RHS, returning
! ... its derivatives dxdt(1:n), a second-order Runge-Kutta (midpoint)
! ... method is used to advance the solution over an interval h and return
! ... the incremented variable as xn(1:n).
! ... The user must supply the subroutine RHS(t,x,dxdt) returning
! ... derivatives dxdt at t.

integer, intent(in)                  :: n
real(dp), intent(in)                 :: t,h
real(dp), dimension(n), intent(in)   :: x
real(dp), dimension(n), intent(out)  :: xn
EXTERNAL                             :: RHS

! ... Local variables
! ...
real(dp), dimension(n)               :: k1,k2

CALL RHS(n,t,x,k1)
k1 = h*k1

CALL RHS(n,t+0.5D0*h,x+0.5D0*k1,k2)
k2 = h*k2

xn(:) = x(:) + k2(:)

return
end subroutine rk2
! ...
! =============================================================================
! ...
subroutine rk3 (n,x,t,h,xn,RHS)

! ... Given values for the variables x(1:n) and a function, RHS, returning
! ... its derivatives dxdt(1:n), a second-order Runge-Kutta (midpoint)
! ... method is used to advance the solution over an interval h and return
! ... the incremented variable as xn(1:n).
! ... The user must supply the subroutine RHS(t,x,dxdt) returning
! ... derivatives dxdt at t.

integer, intent(in)                  :: n
real(dp), intent(in)                 :: t,h
real(dp), dimension(n), intent(in)   :: x
real(dp), dimension(n), intent(out)  :: xn
EXTERNAL                             :: RHS

! ... Local variables
! ...
real(dp), dimension(n)               :: k1,k2,k3

CALL RHS(n,t,x,k1)
k1 = h*k1

CALL RHS(n,t+0.5D0*h,x+0.5D0*k1,k2)
k2 = h*k2

CALL RHS(n,t+h,x-k1+2D0*k2,k3)
k3 = h*k3

xn(:) = x(:) + (k1(:) + 4D0*k2(:) + k3(:))/6D0

return
end subroutine rk3
! ...
! =============================================================================
! ...
subroutine rk4 (n,x,t,h,xn,RHS)

! ... Given values for the variables x(1:n) and a function, RHS, returning
! ... its derivatives dxdt(1:n), a fourth-order Runge-Kutta
! ... method is used to advance the solution over an interval h and return
! ... the incremented variable as xn(1:n).
! ... The user must supply the subroutine RHS(t,x,dxdt) returning
! ... derivatives dxdt at t.

integer, intent(in)                  :: n
real(dp), intent(in)                 :: t,h
real(dp), dimension(n), intent(in)   :: x
real(dp), dimension(n), intent(out)  :: xn
EXTERNAL                             :: RHS

! ... Local variables
! ...
real(dp), dimension(n)               :: k1,k2,k3,k4

CALL RHS(n,t,x,k1)
k1 = h*k1

CALL RHS(n,t+0.5D0*h,x+0.5D0*k1,k2)
k2 = h*k2

CALL RHS(n,t+0.5D0*h,x+0.5D0*k2,k3)
k3 = h*k3

CALL RHS(n,t+h,x+k3,k4)
k4 = h*k4

xn(:) = x(:) + (k1(:) + 2D0*k2(:) + 2D0*K3(:) + k4(:))/6D0

return
end subroutine rk4
! ...
! =============================================================================
! ...
subroutine rk5 (n,x,t,h,xn,RHS)

! ... Given values for the variables x(1:n) and a function, RHS, returning
! ... its derivatives dxdt(1:n), a fifth-order Runge-Kutta
! ... method is used to advance the solution over an interval h and return
! ... the incremented variable as xn(1:n).
! ... The user must supply the subroutine RHS(t,x,dxdt) returning
! ... derivatives dxdt at t.
! ... Quim Ballabrera, March 2017.

integer, intent(in)                  :: n
real(dp), intent(in)                 :: t,h
real(dp), dimension(n), intent(in)   :: x
real(dp), dimension(n), intent(out)  :: xn
EXTERNAL                             :: RHS

! ... Local variables
! ...
real(dp), dimension(n)               :: k1,k2,k3,k4,k5,k6

CALL RHS(n,t,x,k1)
k1 = h*k1

CALL RHS(n,t+0.5D0*h,x+0.5D0*k1,k2)
k2 = h*k2

CALL RHS(n,t+0.25D0*h,x+(3D0*k1+k2)/16D0,k3)
k3 = h*k3

CALL RHS(n,t+0.5D0*h,x+0.5D0*k3,k4)
k4 = h*k4

CALL RHS(n,t+0.75D0*h,x+(-3D0*k2+6D0*k3+9D0*k4)/16D0,k5)
k5 = h*k5

CALL RHS(n,t+h,x+(k1+4D0*k2+6D0*k3-12D0*k4+8D0*k5)/7D0,k6)
k6 = h*k6

xn(:) = x(:) + (7D0*k1(:) + 32D0*k3(:) + 12D0*k4(:) + 32D0*k5(:) + 7D0*k6(:))/90D0

return
end subroutine rk5
! ...
! =============================================================================
! ...
end module runge_kutta