program main
    use std
    implicit none

    type(random_):: random
    real(real64) :: array(4,4), val
    integer(int32) :: i,j

    call random%init()
    do i=1, 4
        do j=1, 4
            array(i,j) =  random%random()
        enddo
    enddo
    ! show array on display
    call showArray(array)
    ! export array to a file named "test.txt"
    call showArray(array,Name="test.txt")

end program main


   Module Constants

   Use Precision
   Implicit None
   Real (Kind=pr), Parameter :: Zero = 0.0_pr
   Real (Kind=pr), Parameter :: One  = 1.0_pr
   Real (Kind=pr), Parameter :: Two   = 2.0_pr
   Real (Kind=pr), Parameter :: Three = 3.0_pr
   Real (Kind=pr), Parameter :: Four  = 4.0_pr
   Real (Kind=pr), Parameter :: Pi    = 3.1415926535897932384626433833_pr
   Real (Kind=pr), Parameter :: F12   = One/Two
   Real (Kind=pr), Parameter :: F14   = One/Four
   Real (Kind=pr), Parameter :: F32   = Three/Two
   Real (Kind=pr), Parameter :: F34   = Three/Four
   Real (Kind=pr), Parameter :: F13   = One/Three
   Real (Kind=pr), Parameter :: F43   = Four/Three

   End Module Constants


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id: model_mod.f90 12563 2018-04-26 21:34:00Z nancy@ucar.edu $

! test of the find_first_occurrence() routine in the utilities module.

program find_first_occurrence_test

use types_mod, only : r8
use utilities_mod, only : error_handler, find_first_occurrence, E_MSG, E_ERR
use sort_mod, only : sort, index_sort
use random_seq_mod, only: random_seq_type, init_random_seq, random_gaussian

! make both of these values larger for a real test.
! maybe 50 or 100 for array, 10 or 20 for the samples?
integer, parameter :: MYSIZE = 12
integer, parameter :: NSAMPLES = 2

real(r8), parameter :: BASEVAL = 25.0_r8
real(r8), parameter :: STDDEV = 5.0_r8
type(random_seq_type) :: seq

real(r8) :: array1(MYSIZE), array2(MYSIZE)
real(r8) :: sorted1(MYSIZE), sorted2(MYSIZE)
integer  :: indirect1(MYSIZE)

integer :: seed = 10
integer :: i, this_i, ind_this, istat, j
real(r8) :: thisval, thesevals(MYSIZE), tmp
character(len=512) :: string1

character(len=*), parameter :: routine = 'find_first_occurrence_test'

! calling sequence for routine being tested:
!
!subroutine find_first_occurrence(nitems, data_array, value_to_find, &
!                                 the_index, my_status, inverted, &
!                                 indirect_indicies, the_indirect_index)
!
! should return the largest index number that is less or
! equal to the test value.  last two arguments are optional.

! calling sequence for closely related routine:
!
!subroutine find_enclosing_indices(nitems, data_array, value_to_find,     &
!                                  smaller_index, larger_index, fraction_across, my_status, &
!                                  inverted, log_scale, indirect_indices)
!
! should return the smaller index, larger index, and fraction across.
! last three arguments are optional.

! fill the array with random values and do an initial sanity check
! with none of the special options enabled.

call init_random_seq(seq, seed)

do i=1, MYSIZE
   array1(i) = random_gaussian(seq, BASEVAL, STDDEV)
enddo

! comment this in to add replicated values to the input array
!array1(4) = array1(5)

do i=1, NSAMPLES
   thesevals(i) = random_gaussian(seq, BASEVAL, STDDEV*0.9_r8)
enddo

sorted1 = sort(array1)
call index_sort(array1, indirect1, MYSIZE)

! inverted order arrays - cannot do both inverted and indirect!
do i=1, MYSIZE
   array2(i) = array1(MYSIZE - i + 1)
enddo

do i=1, MYSIZE
   sorted2(i) = sorted1(MYSIZE - i + 1)
enddo

! print generated case data

do i=1, MYSIZE
   write(*, '(A50,2(I4,F8.3))') "item, sort, indirect, val: ", i, sorted1(i), indirect1(i), array1(i)
enddo
write(*,*)""

do i=1, MYSIZE
   write(*, '(A50,1(I4,F8.3))') "item, inverted val: ", i, sorted2(i)
enddo
write(*,*)""

do i=1, NSAMPLES
   write(*, '(A50,I4,F8.3)') "test value, data: ", i, thesevals(i)
enddo
write(*,*)""
write(*,*)""

! real start of tests

write(*,*)"direct tests"

! test edge cases
thisval = sorted1(1)
write(string1, *) "lowest value"
call find_first_occurrence(MYSIZE, sorted1, thisval, this_i, istat)
call print_results(thisval, sorted1, this_i, istat, string1)

thisval = sorted1(MYSIZE)
write(string1, *) "highest value"
call find_first_occurrence(MYSIZE, sorted1, thisval, this_i, istat)
call print_results(thisval, sorted1, this_i, istat, string1)

! test outside range
thisval = sorted1(1) - 1.0_r8
write(string1, *) "below lowest value"
call find_first_occurrence(MYSIZE, sorted1, thisval, this_i, istat)
call print_results(thisval, sorted1, this_i,  istat, string1)

thisval = sorted1(MYSIZE) + 1.0_r8
write(string1, *) "above highest value"
call find_first_occurrence(MYSIZE, sorted1, thisval, this_i, istat)
call print_results(thisval, sorted1, this_i, istat, string1)

! tests for equals
do i=1, MYSIZE
   thisval = sorted1(i)
   write(string1, '(A22,I4,F8.3)') "equal, val: ", i, thisval
   call find_first_occurrence(MYSIZE, sorted1, thisval, this_i, istat)
   call print_results(thisval, sorted1, this_i, istat, string1)
enddo

! tests for non-equals
do i=1, NSAMPLES
   write(string1, '(A22,I4,F8.3)') "noneq, val: ", i, thesevals(i)
   call find_first_occurrence(MYSIZE, sorted1, thesevals(i), this_i, istat)
   call print_results(thesevals(i), sorted1, this_i, istat, string1)
enddo

write(*,*)""
write(*,*)"indirect tests"

! test indirect addressing

! test edge cases
thisval = sorted1(1)
write(string1, *) "lowest value"
call find_first_occurrence(MYSIZE, array1, thisval, this_i, istat, &
                           indirect_indices = indirect1, the_indirect_index = ind_this)
call print_results(thisval, array1, this_i, istat, string1, indirect1, indirect_this = ind_this)

thisval = sorted1(MYSIZE)
write(string1, *) "highest value"
call find_first_occurrence(MYSIZE, array1, thisval, this_i, istat, &
                           indirect_indices = indirect1, the_indirect_index = ind_this)
call print_results(thisval, array1, this_i, istat, string1, indirect1, indirect_this = ind_this)

! test outside range
thisval = sorted1(1) - 1.0_r8
write(string1, *) "below lowest value"
call find_first_occurrence(MYSIZE, array1, thisval, this_i, istat, &
                           indirect_indices = indirect1, the_indirect_index = ind_this)
call print_results(thisval, array1, this_i, istat, string1, indirect1, indirect_this = ind_this)

thisval = sorted1(MYSIZE) + 1.0_r8
write(string1, *) "above highest value"
call find_first_occurrence(MYSIZE, array1, thisval, this_i, istat, &
                           indirect_indices = indirect1, the_indirect_index = ind_this)
call print_results(thisval, array1, this_i, istat, string1, indirect1, indirect_this = ind_this)

! tests for equals
do i=1, MYSIZE
   thisval = sorted1(i)
   write(string1, '(A22,I4,F8.3)') "equal, val: ", i, thisval
   call find_first_occurrence(MYSIZE, array1, thisval, this_i, istat, &
                              indirect_indices = indirect1, the_indirect_index = ind_this)
   call print_results(thisval, array1, this_i, istat, string1, indirect1, indirect_this = ind_this)
enddo

! tests for non-equals
do i=1, NSAMPLES
   write(string1, '(A22,I4,F8.3)') "noneq, val: ", i, thesevals(i)
   call find_first_occurrence(MYSIZE, array1, thesevals(i), this_i, istat, &
                              indirect_indices = indirect1, the_indirect_index = ind_this)
   call print_results(thesevals(i), array1, this_i, istat, string1, indirect1, indirect_this = ind_this)
enddo

write(*,*)""
write(*,*)"inverted tests"

! test inverted arrays

! test edge cases
thisval = sorted1(1)
write(string1, *) "lowest value"
call find_first_occurrence(MYSIZE, sorted2, thisval, this_i, istat, &
                            inverted = .true.)
call print_results(thisval, sorted2, this_i, istat, string1, inverted=.true.)

thisval = sorted1(MYSIZE)
write(string1, *) "highest value"
call find_first_occurrence(MYSIZE, sorted2, thisval, this_i, istat, &
                            inverted = .true.)
call print_results(thisval, sorted2, this_i, istat, string1, inverted=.true.)

! test outside range
thisval = sorted1(1) - 1.0_r8
write(string1, *) "below lowest value"
call find_first_occurrence(MYSIZE, sorted2, thisval, this_i, istat, &
                            inverted = .true.)
call print_results(thisval, sorted2, this_i, istat, string1, inverted=.true.)

thisval = sorted1(MYSIZE) + 1.0_r8
write(string1, *) "above highest value"
call find_first_occurrence(MYSIZE, sorted2, thisval, this_i, istat, &
                            inverted = .true.)
call print_results(thisval, sorted2, this_i, istat, string1, inverted=.true.)

! tests for equals
do i=1, MYSIZE
   thisval = sorted1(i)
   write(string1, '(A22,I4,F8.3)') "equal, val: ", i, thisval
   call find_first_occurrence(MYSIZE, sorted2, thisval, this_i, istat, &
                              inverted = .true.)
   call print_results(thisval, sorted2, this_i, istat, string1, inverted=.true.)
enddo

! tests for non-equals
do i=1, NSAMPLES
   write(string1, '(A22,I4,F8.3)') "noneq, val: ", i, thesevals(i)
   call find_first_occurrence(MYSIZE, sorted2, thesevals(i), this_i, istat, inverted=.true.)
   call print_results(thesevals(i), sorted2, this_i, istat, string1, inverted=.true.)
enddo

write(*,*)""
write(*,*)"invalid input tests"

! empty array
write(string1, '(A6,I4)') "single item array"
call find_first_occurrence(0, sorted1(1:1), thesevals(1), this_i, istat)
call print_results(thesevals(1), sorted1, this_i, istat, string1)

! indirect and inverted
write(string1, '(A6,I4)') "indirect and inverted"
call find_first_occurrence(MYSIZE, sorted1, thesevals(1), this_i, istat, &
                           inverted=.true., indirect_indices=indirect1)
call print_results(thesevals(1), sorted1, this_i, istat, string1)

! indirect_this without indirect array
write(string1, '(A6,I4)') "indirect this w/o array"
call find_first_occurrence(MYSIZE, array1, thisval, this_i, istat, &
                           the_indirect_index = ind_this)
call print_results(thisval, array1, this_i, istat, string1, indirect1, indirect_this = ind_this)
call print_results(thesevals(1), array1, this_i, istat, string1)

! inverted (badly sorted) input array
write(string1, '(A6,I4)') "non-monotonic array"
call find_first_occurrence(MYSIZE, array1, array1(MYSIZE/2), this_i, istat)
call print_results(array1(MYSIZE/2), array1, this_i, istat, string1)

! almost sorted input array
write(string1, '(A6,I4)') "mostly sorted array"
j = MYSIZE/3
tmp = sorted1(j)
sorted1(j) = sorted1(j*2)
sorted1(j*2) = tmp
call find_first_occurrence(MYSIZE, sorted1, sorted1(MYSIZE/2), this_i, istat)
call print_results(sorted1(MYSIZE/2), sorted1, this_i, istat, string1)

write(*,*) 'end of test'

contains

subroutine print_results(thisval, thisarray, this_i, istat, label, indirect_a, inverted, indirect_this)
 real(r8), intent(in) :: thisval
 real(r8), intent(in) :: thisarray(:)
 integer,  intent(in) :: this_i
 integer,  intent(in) :: istat
 character(len=*), intent(in) :: label
 integer,  intent(in), optional :: indirect_a(:)
 logical,  intent(in), optional :: inverted
 integer,  intent(in), optional :: indirect_this

integer :: this, next

if (istat /= 0) then
   write(*, '(A56,2I8)') trim(label) // ' index, status = ', this_i, istat
   return
endif

write(*,'(A56,F8.3,I4,2F8.3)') trim(label) // ' val, indx, arrval = ', &
                               thisval, this_i, thisarray(this_i)

! indirect_a has to be present if indirect_this is specified.
if (present(indirect_this)) then
    if (.not. present(indirect_a)) then
       print *, 'bad call to print_results: indirect_this specified but not indirect_a'
       stop
    endif
    this = indirect_a(indirect_this)
    next = indirect_a(min(indirect_this + 1, size(thisarray)))
else if (present(inverted)) then
    this = this_i
    next = max(this_i - 1, 1)
else
    this = this_i
    next = min(this_i + 1, size(thisarray))
endif

if (thisval < thisarray(this) .or. thisval > thisarray(next)) then
   write(*,'(A,3F8.3)') 'unexpected error - val not between the two values, ', &
                         thisval, thisarray(this), thisarray(next)
endif

end subroutine print_results

end program find_first_occurrence_test


!   Util Module
    module Util
        implicit none
        character, parameter :: ENDL = ACHAR(10)
        character, parameter :: TAB = ACHAR(9)

        double precision :: DINF, DNINF, DNAN
        DATA DINF/x'7ff0000000000000'/, DNINF/x'fff0000000000000'/, DNAN/x'7ff8000000000000'/

        double precision :: PI = 4.0D0 * DATAN(1.0D0)

        logical :: DEBUG_MODE = .FALSE.
        logical :: QUIET_MODE = .FALSE.

        type StringArray
            character (:), allocatable :: str
        end type StringArray
    contains

    function EDGE(x) result (y)
        double precision, intent(in) :: x
        logical :: y

        y = ISNAN(x) .OR. (x == DINF) .OR. (x == DNINF)
        return
    end function

    function VEDGE(x) result (y)
        double precision, dimension(:), intent(in) :: x
        logical :: y

        y = ANY(ISNAN(x)) .OR. ANY(x == DINF) .OR. ANY(x == DNINF)
        return
    end function

    function MEDGE(x) result (y)
        double precision, dimension(:, :), intent(in) :: x
        logical :: y

        y = ANY(ISNAN(x)) .OR. ANY(x == DINF) .OR. ANY(x == DNINF)
        return
    end function

        function quote(s, q) result (r)
            character(len=*), intent(in) :: s
            character(len=*), optional, intent(in) :: q
            character(len=:), allocatable :: t_q
            character(len=:), allocatable :: r

            if (.NOT. PRESENT(q)) then
                t_q = '"'
            else
                t_q = q
            end if

            r = t_q//s//t_q
        end function

        function DLOG2(x) result (y)
            implicit none
            double precision, intent(in) :: x
            double precision :: y

            y = DLOG(x) / DLOG(2.0D0)
            return
        end function

        function ILOG2(n) result (k)
            integer, intent(in) :: n
            integer :: k
            double precision :: x
            x = n
            x = DLOG2(x)
            k = FLOOR(x)
            return
        end function

!       ==== Random seed Initialization ====
        subroutine init_random_seed()
            integer :: i, n, clock
            integer, allocatable :: seed(:)

            call RANDOM_SEED(SIZE=n)
            allocate(seed(n))
            call SYSTEM_CLOCK(COUNT=clock)
            seed = clock + 37 * (/ (i - 1, i = 1, n) /)
            call RANDOM_SEED(PUT=seed)
            deallocate(seed)
        end subroutine

        function DRAND(a, b) result (y)
            implicit none
            double precision :: a, b, x, y
            ! x in [0, 1)
            call RANDOM_NUMBER(x)
            y = (x * (b - a)) + a
            return
        end function

!       ===== I/O Metods =====
        function STR(k) result (t)
!       "Convert an integer to string."
            integer, intent(in) :: k
            character(len=128) :: s
            character(len=:), allocatable :: t
            write(s, *) k
            t = TRIM(ADJUSTL(s))
            return
            return
        end function

        function DSTR(x) result (q)
            integer :: j, k
            double precision, intent(in) :: x
            character(len=64) :: s
            character(len=:), allocatable :: p, q

            if (ISNAN(x)) then
                q = '?'
                return
            else if (x == DINF) then
                q = '∞'
                return
            else if (x == DNINF) then
                q = '-∞'
                return
            end if

            write(s, *) x
            p = TRIM(ADJUSTL(s))
            do j=LEN(p), 1, -1
                if (p(j:j) == '0') then
                    continue
                else if (p(j:j) == '.') then
                    k = j - 1
                    exit
                else
                    k = j
                    exit
                end if
            end do
            q = p(:k)
            return
        end function

        subroutine display(text, ansi_code)
            implicit none
            character(len=*) :: text
            character(len=*), optional :: ansi_code
            if (QUIET_MODE) then
                return
            else
                if (PRESENT(ansi_code)) then
                    write (*, *) ''//achar(27)//'['//ansi_code//'m'//text//''//achar(27)//'[0m'
                else
                    write (*, *) text
                end if
            end if
        end subroutine

        subroutine error(text)
!           Red Text
            implicit none
            character(len=*) :: text
            call display(text, '31')
        end subroutine

        subroutine warn(text)
!           Yellow Text
            implicit none
            character(len=*) :: text
            call display(text, '93')
        end subroutine

        subroutine debug(text)
!           Yellow Text
            implicit none
            character(len=*) :: text
            if (DEBUG_MODE) then
                call display('[DEBUG] '//text, '93')
            end if
        end subroutine

        subroutine info(text)
!           Green Text
            implicit none
            character(len=*) :: text
            call display(text, '32')
        end subroutine

        subroutine blue(text)
!           Blue Text
            implicit none
            character(len=*) :: text
            call display(text, '36')
        end subroutine

        subroutine show(var, val)
!           Violet Text
            implicit none
            character(len=*) :: var
            double precision :: val
            write (*, *) ''//achar(27)//'[36m'//var//' = '//DSTR(val)//''//achar(27)//'[0m'
        end subroutine

        recursive subroutine cross_quick_sort(x, y, u, v, n)
            integer :: n, i, j, u, v
            double precision :: p, aux, auy
            double precision :: x(n), y(n)

            i = u
            j = v

            p = x((u + v) / 2)

            do while (i <= j)
                do while (x(i) < p)
                    i = i + 1
                end do
                do while(x(j) > p)
                    j = j - 1
                end do
                if (i <= j) then
                    aux = x(i)
                    auy = y(i)
                    x(i) = x(j)
                    y(i) = y(j)
                    x(j) = aux
                    y(j) = auy
                    i = i + 1
                    j = j - 1
                end if
            end do

            if (u < j) then
                call cross_quick_sort(x, y, u, j, n)
            end if
            if (i < v) then
                call cross_quick_sort(x, y, i, v, n)
            end if
            return
        end subroutine

        subroutine cross_sort(x, y, n)
            implicit none
            integer :: n
            double precision :: x(n), y(n)

            call cross_quick_sort(x, y, 1, n, n)
        end subroutine

        subroutine linspace(a, b, dt, n, t)
            implicit none
            integer :: k, n
            double precision, intent(in) :: a, b, dt
            double precision, dimension(:), allocatable :: t
            n = 1 + FLOOR((b - a) / dt)
            allocate(t(n))
            t(:) = dt * (/ (k, k=0, n-1) /)
        end subroutine
    end module Util


SUBROUTINE findNext(x, ix, R, n)
  IMPLICIT NONE
  INTEGER, intent(inout) :: ix
  REAL*8, intent(in)  :: R(n)
  REAL*8, intent(in)  :: x
  INTEGER, intent(in) :: n
  !f2py integer intent(hide), depend(R)      :: n = shape(R,0)
  INTEGER :: i

  if (x.le.R(1)) then
     ix=1
     return
  endif
  if (x.gt.R(n-1)) then
     ix=n-1
     return
  endif
  if (ix.lt.1) then
     ix=1
  endif
  if (ix.gt.n) then
     ix=n
  endif
  if (x.ge.R(ix)) then
     do i=ix,n
        if (R(i).ge.x) then
           ix = i-1
           return
        endif
     enddo
     ix = n-1
     return
  else
     do i=ix,1,-1
        if (x.gt.R(i)) then
           ix = i
           return
        endif
     enddo
     ix=1
     return
  endif
end SUBROUTINE findNext

subroutine interp(res, f, x, ix, R, n)
  IMPLICIT NONE
  COMPLEX*16, intent(out) :: res
  COMPLEX*16, intent(in)  :: f(n)
  REAL*8, intent(in)  :: x
  INTEGER, intent(in) :: ix
  REAL*8, intent(in)  :: R(n)
  INTEGER, intent(in) :: n
  !f2py integer intent(hide), depend(R)      :: n = shape(R,0)
  if (x.lt.R(ix) .or. x.gt.R(ix+1)) then
     print *, 'Tezave:', x, R(ix), R(ix+1), ix, n
  endif
  res = f(ix) + (f(ix+1)-f(ix))*(x-R(ix))/(R(ix+1)-R(ix))
  return
end subroutine interp


! { dg-do run }
! PR39304 write of  0.0 with F0.3 gives  **
! PR47567 Small absolute values.
! Test case developed from case provided by reporter.
 REAL :: x
 CHARACTER(80) :: str
 x = 0.0
 write (str,'(f0.0)') x
 if (str.ne."0.") call abort
 write (str,'(f0.1)') x
 if (str.ne.".0") call abort
 write (str,'(f0.2)') x
 if (str.ne.".00") call abort
 write (str,'(f0.3)') x
 if (str.ne.".000") call abort
 write (str,'(f0.4)') x
 if (str.ne.".0000") call abort
 write (str,'(F0.0)') 0.0
 if (str.ne."0.") call abort
 write (str,'(F0.0)') 0.001
 if (str.ne."0.") call abort
 write (str,'(F0.0)') 0.01
 if (str.ne."0.") call abort
 write (str,'(F0.0)') 0.1
 if (str.ne."0.") call abort
 write (str,'(F1.0)') -0.0
 if (str.ne."*") call abort
 write (str,'(F1.0)') 0.001
 if (str.ne."*") call abort
 write (str,'(F1.0)') 0.01
 if (str.ne."*") call abort
 write (str,'(F1.0)') 0.1
 if (str.ne."*") call abort
 write (str,'(F2.0)') -0.001
 if (str.ne."**") call abort
 write (str,'(F2.0)') -0.01
 if (str.ne."**") call abort
 write (str,'(F2.0)') -0.1
 if (str.ne."**") call abort
 write (str,'(F0.2)') 0.0
 if (str.ne.".00") call abort
 write (str,'(F0.0)') -0.0
 if (str.ne."-0.") call abort
 write (str,'(F0.1)') -0.0
 if (str.ne."-.0") call abort
 write (str,'(F0.2)') -0.0
 if (str.ne."-.00") call abort
 write (str,'(F0.3)') -0.0
 if (str.ne."-.000") call abort
 write (str,'(F3.0)') -0.0
 if (str.ne."-0.") call abort
 write (str,'(F2.0)') -0.0
 if (str.ne."**") call abort
 write (str,'(F1.0)') -0.0
 if (str.ne."*") call abort
 write (str,'(F0.1)') -0.0
 if (str.ne."-.0") call abort
 write (str,'(F3.1)') -0.0
 if (str.ne."-.0") call abort
 write (str,'(F2.1)') -0.0
 if (str.ne."**") call abort
 write (str,'(F1.1)') -0.0
 if (str.ne."*") call abort
 END


*dk, schmidt_hilbert

        subroutine inv_schmidt_hilbert_lg
     &          (epsilon,MXD1,MXD2,ndim1,ndim2
     &           ,array,ainv,iarb,arb,work)

C #####################################################################
C
C     PURPOSE -
C
C        Invert general array using Schmidt-Hilbert Orthonormalization
C        (can be singular, non-symmetric, non-square array).
C
C        subroutine to apply this inverse to a vector
C        also included below (solv_Mxb_schmidt_hilbert_lg)
C
C     INPUT ARGUMENTS -
C
C        epsilon - Directions which occur in array with
C                      norm / (typical norm) < epsilon
C                  are considered part of the "arbitrary" space
C                  (hence epsilon is a relative accuracy;
C                   see below for "typical norm")
C        MXD1,MXD2,ndim1,ndim2
C                - MAX/actual dimenions of array,ainv
C        array   - the array to invert
C
C     WORKSPACE ARGUMENTS -
C
C        work    - workspace (contents ignored)
C
C     OUTPUT ARGUMENTS -
C
C        ainv - the inverse of array
C        iarb, arb -
C             iarb(k)=0 if the matrix is not singular
C                    >0 if the matrix is singular
C                       and an arbitrary amount of arb(k,i)
C                       can be added to soln(i)
C                       [ arb(k,i) is normalized ]
C                    <0 procedure yield iarb>0,
C                       but test |array*arb| < eps failed
C                       [ if |arb| non-zero, it is normalized after test ]
C
C     PROGRAMMING NOTES -
C
C        logical sizes for eps are
C           (epsilon)*[ typical sqrt(sum_j array(j,i)^2) ]
C        or (epsilon)*[ typical entry of array ]
C        where epsilon is the desired (input) relative accuracy.
C        The trade off is how "localized eigenvectors" are
C        weighted (already-diagonal entries will need to have
C        a comparable size to the "typical" entry).
C        For now, the first form is used.
C
C        For matricies with both "large" and "small" entries,
C        where the eignevectors for each are desired, a different
C        routine, such as LUD decomposition, is required.
C
C     CHANGE HISTORY -
C
C     $Log: inv_schmidt_hilbert_lg.f,v $
C     Revision 2.00  2007/11/03 00:49:11  spchu
C     Import to CVS
C
CPVCS
CPVCS       Rev 1.2   Mon Oct 25 16:30:14 1999   jtg
CPVCS    fixed missing scale in epsilon test in solv routine
CPVCS
CPVCS       Rev 1.1   Tue Oct 19 14:57:20 1999   jtg
CPVCS    fixed local_debug flag (was non-zero)
CPVCS
CPVCS       Rev 1.0   Tue Oct 19 13:05:52 1999   jtg
CPVCS    Initial revision.
C
C ######################################################################
        implicit none

        integer ndim1,ndim2,MXD1,MXD2
        real*8 eps,epsilon
        real*8 array(MXD1,ndim2),ainv(MXD2,ndim1)
     &          ,arb(MXD2,ndim2),work(MXD2,ndim1)
        integer iarb(ndim2)

        integer i,j,k,l,local_debug,iway
        real*8 xnorm,dotij,qq,qqq
c ........................................................................
        local_debug=0
10      format(1x,4g13.4)

        if (ndim2.le.0.or.ndim2.gt.MXD2) goto 9999
        if (ndim1.le.0.or.ndim1.gt.MXD1) goto 9999

c calculate eps with units to use in calculation
        eps=0.d0
        iway=1
        if (iway.eq.1) then
           ! compare to "typical" (max) norm
           do i=1,ndim1
             qq=0.d0
             do j=1,ndim2
               qqq=array(i,j)
               qq=qq+qqq*qqq
             enddo
             if (qq.gt.eps) eps=qq
           enddo
        else
           ! compare to "typical" (max) entry
           do i=1,ndim1
             do j=1,ndim2
               qqq=abs(array(i,j))
               if (qqq.gt.eps) eps=qqq
             enddo
           enddo
        endif
        eps=eps*epsilon

c initialize ainv
        do i=1,ndim2
          do j=1,ndim1
            ainv(i,j)=0.d0
          enddo
        enddo

        do i=1,ndim2

c initialize work vector
          do j=1,ndim1
            work(i,j)=array(j,i)
          enddo

c make work vector normal
          xnorm=0.d0
          do j=1,ndim1
            xnorm=xnorm+work(i,j)*work(i,j)
          enddo
          xnorm=sqrt(xnorm)

          if (xnorm.le.eps) then

c no vector: set iarb so don't use
            iarb(i)=1

          else

c initialize arb
            do j=1,ndim1
              work(i,j)=work(i,j)/xnorm
            enddo
            do j=1,ndim2
              arb(i,j)=0.d0
            enddo
            arb(i,i)=1.d0/xnorm

c make ith work vector normal to all below it
            do j=1,i-1
              if (iarb(j).eq.0) then
                dotij=0.d0
                do l=1,ndim1
                  dotij=dotij+work(i,l)*work(j,l)
                enddo
                do l=1,ndim1
                  work(i,l)=work(i,l)-dotij*work(j,l)
                enddo
                do l=1,ndim2
                  arb(i,l)=arb(i,l)-dotij*arb(j,l)
                enddo
              endif
            enddo

c re-normalize ith work vector
            xnorm=0.d0
            do l=1,ndim1
              xnorm=xnorm+work(i,l)*work(i,l)
            enddo
            xnorm=sqrt(xnorm)

            if (xnorm.le.eps) then

c if no new piece of vector: set iarb so don't use
              iarb(i)=2

            else

c update work, arb
              iarb(i)=0
              do l=1,ndim1
                work(i,l)=work(i,l)/xnorm
              enddo
              do l=1,ndim2
                arb(i,l)=arb(i,l)/xnorm
              enddo

c increment ainv
              do k=1,ndim2
                do j=1,ndim1
                  ainv(k,j)=ainv(k,j)+work(i,j)*arb(i,k)
                enddo
              enddo

            endif

          endif

        enddo

c should have ainv at this point, plus allowed arbitrary vectors
c test and normalize allowed arbitrary vectors
c set flag to negative if fail

        do i=1,ndim2

          if (iarb(i).eq.0) then

            ! zero arb in case used accidentally
            do j=1,ndim2
              arb(i,j)=0.d0
            enddo

          elseif (iarb(i).eq.1) then

            ! no vector in this direction: set arb to delta(i,j)
            do j=1,ndim2
              arb(i,j)=0.d0
            enddo
            arb(i,i)=1.d0

          else ! if (iarb(i).eq.2) then

            qq=0.d0
            do j=1,ndim2
              qq=qq+arb(i,j)*arb(i,j)
            enddo
            qq=sqrt(qq)
            if (qq.le.eps) then
              if (local_debug.gt.0)
     &          write(*,*) '*** iarb.ne.0, |arb|=0, not using i=',i
              iarb(i)=-1
              ! normalize if possible
              if (qq.ne.0.d0) then
                 qq=1.d0/(qq)
                 do j=1,ndim2
                   arb(i,j)=arb(i,j)*qq
                 enddo
              endif
            else
              qq=1.d0/(qq)
              do j=1,ndim2
                arb(i,j)=arb(i,j)*qq
              enddo
              qqq=0.d0
              do k=1,ndim1
                qq=0.d0
                do j=1,ndim2
                  qq=qq+array(k,j)*arb(i,j)
                enddo
                qqq=qqq+qq*qq
              enddo
              qqq=sqrt(qqq)
              if (qqq.gt.eps) then
                if (local_debug.gt.0) write(*,*)
     &            '*** iarb.ne.0, |M(arb)|.ne.0, not using i=',i
                iarb(i)=-1
              endif
            endif
            if (local_debug.gt.0) then
              write(*,*) 'zero eigenvalue vector ',i*iarb(i)
              write(*,10) (arb(i,j),j=1,ndim2)
            endif

          endif

        enddo

c count indep vectors and print ainv
        if (local_debug.gt.0) then
          j=0
          do i=1,ndim2
            if (iarb(i).eq.0) j=j+1
          enddo
          write(*,*) 'a^T has',j,' independent vectors'
          write(*,*)'ainv'
          do i=1,ndim2
            write(*,10)(ainv(i,j),j=1,ndim1)
          enddo
        endif

        ! sucessful return
1000    return

        ! error return
9999    continue
        if (local_debug.gt.1) stop 'schmidt_hilbert_inv_lg error'
        call writloga('default',0,
     &  'Warning: schmidt_hilbert_inv_lg: array dimensions not allowed'
     &  ,0,i)
        return

        end

c ===========================================
        subroutine solv_Mxb_schmidt_hilbert_lg
     &          (epsilon,MXD1,MXD2,ndim1,ndim2
     &           ,array,vec,sol,ainv,iarb,arb,work)

C #####################################################################
C
C     PURPOSE -
C
C        solve general Mx=b using Schmidt-Hilbert Orthonormalization
C        (M can be singular, non-symmetric, non-square array).
C
C     ARGUMENTS same as for inv_schmidt_hilbert_lg -
C
C        epsilon, MXD1,MXD2,ndim1,ndim2
C        array, work, ainv, iarb, arb
C
C     ADDITIONAL ARGUMENTS -
C
C        vec - the (input) b vector in MX=b
C        sol - the (output) x solution vector to MX=b
C
C     PROGRAMMING NOTES -
C
C        after calling inv_schmidt_hilbert_lg, the solution
C        is optimized (minimal magnitude, best fit)
C        wrt the arbitrary vectors. This is probably not necessary.
C
C     CHANGE HISTORY -
C
C        $Log: inv_schmidt_hilbert_lg.f,v $
C        Revision 2.00  2007/11/03 00:49:11  spchu
C        Import to CVS
C
C
C ######################################################################
        implicit none

        integer ndim1,ndim2,MXD1,MXD2
        real*8 epsilon
        real*8 array(MXD1,ndim2),ainv(MXD2,ndim1)
     &          ,arb(MXD2,ndim2),work(MXD2,ndim1)
     &          ,vec(ndim1),sol(ndim2)
        integer iarb(ndim2)

        integer i,j,local_debug
        real*8 qq,qqq,xerr,q1,q2,scale

c ........................................................................

        local_debug=0
10      format(1x,4g13.4)

        call inv_schmidt_hilbert_lg
     &       (epsilon,MXD1,MXD2,ndim1,ndim2
     &       ,array,ainv,iarb,arb,work)

30      do i=1,ndim2
          sol(i)=0.d0
          do j=1,ndim1
            sol(i)=sol(i)+ainv(i,j)*vec(j)
          enddo
        enddo

        if (local_debug.gt.0) then
           write(*,*) (sol(i),i=1,ndim2)
        endif

        ! minimize magnitude wrt (normalized) arbitrary components
        ! since arb normalized, don't need epsilon test?
        do i=1,ndim2
          if (iarb(i).gt.0) then
            qqq=0.d0
            do j=1,ndim2
              qqq=qqq+arb(i,j)*sol(j)
            enddo
            do j=1,ndim2
              sol(j)=sol(j)-arb(i,j)*qqq
            enddo
          endif
        enddo

        ! test that sol - if not, use best fit
        ! find scale for vec
        scale=0.d0
        do i=1,ndim1
           scale=scale+vec(i)*vec(i)
        enddo

        ! test that sol - if not, use best fit
        xerr=0.d0
        q1=0.d0
        q2=0.d0
        do i=1,ndim1
          work(1,i)=0.d0
          do j=1,ndim2
            work(1,i)=work(1,i)+array(i,j)*sol(j)
          enddo
          qq=work(1,i)-vec(i)
          xerr=xerr+qq*qq
          q1=q1+work(1,i)*vec(i)
          q2=q2+work(1,i)*work(1,i)
        enddo
        if (xerr.gt.epsilon*scale) then
           if (local_debug.gt.0)
     &       write(*,*) '*** NO sol WITH THIS vec ***'
           ! scale to best fit magnitude
           if (q2.gt.epsilon*scale) then
             q1=q1/q2
             do i=1,ndim2
               sol(i)=sol(i)*q1
             enddo
           else
             do i=1,ndim2
               sol(i)=0.d0
             enddo
           endif
           xerr=0.d0
           do i=1,ndim1
             qq=0.d0
             do j=1,ndim2
               qq=qq+array(i,j)*sol(j)
             enddo
             qq=qq-vec(i)
             xerr=xerr+qq*qq
           enddo
        endif

        if (local_debug.gt.0) then
           write(*,*)'(sol(i),i=1,',ndim2,')'
           write(*,10)(sol(i),i=1,ndim2)
           write(*,*)'xerr=',xerr
        endif

40      continue

        return

        end

c ===========================================


!***********************************************************************
!   Copyright (c) 2019 D. de Vries
!   Original Copyright (c) 2000 Mark Drela
!
!   This file is part of XFoil.
!
!   XFoil 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 3 of the License, or
!   (at your option) any later version.
!
!   XFoil 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 XFoil.  If not, see <https://www.gnu.org/licenses/>.
!***********************************************************************

!*==M_SPLINE.f90  processed by SPAG 7.21DC at 11:25 on 11 Jan 2019
module m_spline
    implicit none
    !
    !*** Start of declarations rewritten by SPAG
    !
    !*** End of declarations rewritten by SPAG
    !
    !
    !*** Start of declarations rewritten by SPAG
    !
    !*** End of declarations rewritten by SPAG
    !
contains
    subroutine spline(X, Xs, S, N)
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! PARAMETER definitions
        !
        integer, parameter :: NMAX = 1000
        !
        ! Dummy arguments
        !
        integer :: N
        real, dimension(N) :: S, X, Xs
        intent (in) S, X
        !
        ! Local variables
        !
        real, dimension(NMAX) :: a, b, c
        real :: dsm, dsp
        integer :: i
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! PARAMETER definitions
        !
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !-------------------------------------------------------
        !     Calculates spline coefficients for X(S).          |
        !     Zero 2nd derivative end conditions are used.      |
        !     To evaluate the spline at some value of S,        |
        !     use SEVAL and/or DEVAL.                           |
        !                                                       |
        !     S        independent variable array (input)       |
        !     X        dependent variable array   (input)       |
        !     XS       dX/dS array                (calculated)  |
        !     N        number of points           (input)       |
        !                                                       |
        !-------------------------------------------------------
        if (N>NMAX) stop 'SPLINE: array overflow, increase NMAX'
        !
        do i = 2, N - 1
            dsm = S(i) - S(i - 1)
            dsp = S(i + 1) - S(i)
            b(i) = dsp
            a(i) = 2.0 * (dsm + dsp)
            c(i) = dsm
            Xs(i) = 3.0 * ((X(i + 1) - X(i)) * dsm / dsp + (X(i) - X(i - 1)) * dsp / dsm)
        enddo
        !
        !---- set zero second derivative end conditions
        a(1) = 2.0
        c(1) = 1.0
        Xs(1) = 3.0 * (X(2) - X(1)) / (S(2) - S(1))
        b(N) = 1.0
        a(N) = 2.0
        Xs(N) = 3.0 * (X(N) - X(N - 1)) / (S(N) - S(N - 1))
        !
        !---- solve for derivative array XS
        call trisol(a, b, c, Xs, N)
        !
    end subroutine spline
    ! SPLINE

    subroutine splind(X, Xs, S, N, Xs1, Xs2)
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! PARAMETER definitions
        !
        integer, parameter :: NMAX = 1000
        !
        ! Dummy arguments
        !
        integer :: N
        real :: Xs1, Xs2
        real, dimension(N) :: S, X, Xs
        intent (in) S, X, Xs1, Xs2
        !
        ! Local variables
        !
        real, dimension(NMAX) :: a, b, c
        real :: dsm, dsp
        integer :: i
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! PARAMETER definitions
        !
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !-------------------------------------------------------
        !     Calculates spline coefficients for X(S).          |
        !     Specified 1st derivative and/or usual zero 2nd    |
        !     derivative end conditions are used.               |
        !     To evaluate the spline at some value of S,        |
        !     use SEVAL and/or DEVAL.                           |
        !                                                       |
        !     S        independent variable array (input)       |
        !     X        dependent variable array   (input)       |
        !     XS       dX/dS array                (calculated)  |
        !     N        number of points           (input)       |
        !     XS1,XS2  endpoint derivatives       (input)       |
        !              If = 999.0, then usual zero second       |
        !              derivative end condition(s) are used     |
        !              If = -999.0, then zero third             |
        !              derivative end condition(s) are used     |
        !                                                       |
        !-------------------------------------------------------
        if (N>NMAX) stop 'SPLIND: array overflow, increase NMAX'
        !
        do i = 2, N - 1
            dsm = S(i) - S(i - 1)
            dsp = S(i + 1) - S(i)
            b(i) = dsp
            a(i) = 2.0 * (dsm + dsp)
            c(i) = dsm
            Xs(i) = 3.0 * ((X(i + 1) - X(i)) * dsm / dsp + (X(i) - X(i - 1)) * dsp / dsm)
        enddo
        !
        if (Xs1==999.0) then
            !----- set zero second derivative end condition
            a(1) = 2.0
            c(1) = 1.0
            Xs(1) = 3.0 * (X(2) - X(1)) / (S(2) - S(1))
        elseif (Xs1==-999.0) then
            !----- set zero third derivative end condition
            a(1) = 1.0
            c(1) = 1.0
            Xs(1) = 2.0 * (X(2) - X(1)) / (S(2) - S(1))
        else
            !----- set specified first derivative end condition
            a(1) = 1.0
            c(1) = 0.
            Xs(1) = Xs1
        endif
        !
        if (Xs2==999.0) then
            b(N) = 1.0
            a(N) = 2.0
            Xs(N) = 3.0 * (X(N) - X(N - 1)) / (S(N) - S(N - 1))
        elseif (Xs2==-999.0) then
            b(N) = 1.0
            a(N) = 1.0
            Xs(N) = 2.0 * (X(N) - X(N - 1)) / (S(N) - S(N - 1))
        else
            a(N) = 1.0
            b(N) = 0.
            Xs(N) = Xs2
        endif
        !
        if (N==2 .and. Xs1==-999.0 .and. Xs2==-999.0) then
            b(N) = 1.0
            a(N) = 2.0
            Xs(N) = 3.0 * (X(N) - X(N - 1)) / (S(N) - S(N - 1))
        endif
        !
        !---- solve for derivative array XS
        call trisol(a, b, c, Xs, N)
        !
    end subroutine splind
    ! SPLIND

    subroutine splina(X, Xs, S, N)
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        integer :: N
        real, dimension(N) :: S, X, Xs
        intent (in) N, S, X
        intent (out) Xs
        !
        ! Local variables
        !
        real :: ds, dx, xs1, xs2
        integer :: i
        logical :: lend
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !-------------------------------------------------------
        !     Calculates spline coefficients for X(S).          |
        !     A simple averaging of adjacent segment slopes     |
        !     is used to achieve non-oscillatory curve          |
        !     End conditions are set by end segment slope       |
        !     To evaluate the spline at some value of S,        |
        !     use SEVAL and/or DEVAL.                           |
        !                                                       |
        !     S        independent variable array (input)       |
        !     X        dependent variable array   (input)       |
        !     XS       dX/dS array                (calculated)  |
        !     N        number of points           (input)       |
        !                                                       |
        !-------------------------------------------------------
        !
        lend = .true.
        do i = 1, N - 1
            ds = S(i + 1) - S(i)
            if (ds==0.) then
                Xs(i) = xs1
                lend = .true.
            else
                dx = X(i + 1) - X(i)
                xs2 = dx / ds
                if (lend) then
                    Xs(i) = xs2
                    lend = .false.
                else
                    Xs(i) = 0.5 * (xs1 + xs2)
                endif
            endif
            xs1 = xs2
        enddo
        Xs(N) = xs1
        !
    end subroutine splina
    ! SPLINA

    subroutine trisol(A, B, C, D, Kk)
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        integer :: Kk
        real, dimension(Kk) :: A, B, C, D
        intent (in) B, Kk
        intent (inout) A, C, D
        !
        ! Local variables
        !
        integer :: k, km
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !-----------------------------------------
        !     Solves KK long, tri-diagonal system |
        !                                         |
        !             A C          D              |
        !             B A C        D              |
        !               B A .      .              |
        !                 . . C    .              |
        !                   B A    D              |
        !                                         |
        !     The righthand side D is replaced by |
        !     the solution.  A, C are destroyed.  |
        !-----------------------------------------
        !
        do k = 2, Kk
            km = k - 1
            C(km) = C(km) / A(km)
            D(km) = D(km) / A(km)
            A(k) = A(k) - B(k) * C(km)
            D(k) = D(k) - B(k) * D(km)
        enddo
        !
        D(Kk) = D(Kk) / A(Kk)
        !
        do k = Kk - 1, 1, -1
            D(k) = D(k) - C(k) * D(k + 1)
        enddo
        !
    end subroutine trisol
    ! TRISOL

    function seval(Ss, X, Xs, S, N)
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        integer :: N
        real :: Ss
        real, dimension(N) :: S, X, Xs
        real :: seval
        intent (in) N, S, Ss, X, Xs
        !
        ! Local variables
        !
        real :: cx1, cx2, ds, t
        integer :: i, ilow, imid
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !--------------------------------------------------
        !     Calculates X(SS)                             |
        !     XS array must have been calculated by SPLINE |
        !--------------------------------------------------
        ilow = 1
        i = N
        !
        do while (i - ilow>1)
            !
            imid = (i + ilow) / 2
            if (Ss<S(imid)) then
                i = imid
            else
                ilow = imid
            endif
        enddo
        !
        ds = S(i) - S(i - 1)
        t = (Ss - S(i - 1)) / ds
        cx1 = ds * Xs(i - 1) - X(i) + X(i - 1)
        cx2 = ds * Xs(i) - X(i) + X(i - 1)
        seval = t * X(i) + (1.0 - t) * X(i - 1) + (t - t * t) * ((1.0 - t) * cx1 - t * cx2)
    end function seval
    ! SEVAL

    function deval(Ss, X, Xs, S, N)
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        integer :: N
        real :: Ss
        real :: deval
        real, dimension(N) :: S, X, Xs
        intent (in) N, S, Ss, X, Xs
        !
        ! Local variables
        !
        real :: cx1, cx2, ds, t
        integer :: i, ilow, imid
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !--------------------------------------------------
        !     Calculates dX/dS(SS)                         |
        !     XS array must have been calculated by SPLINE |
        !--------------------------------------------------
        ilow = 1
        i = N
        !
        do while (i - ilow>1)
            !
            imid = (i + ilow) / 2
            if (Ss<S(imid)) then
                i = imid
            else
                ilow = imid
            endif
        enddo
        !
        ds = S(i) - S(i - 1)
        t = (Ss - S(i - 1)) / ds
        cx1 = ds * Xs(i - 1) - X(i) + X(i - 1)
        cx2 = ds * Xs(i) - X(i) + X(i - 1)
        deval = X(i) - X(i - 1) + (1. - 4.0 * t + 3.0 * t * t) * cx1 + t * (3.0 * t - 2.) * cx2
        deval = deval / ds
    end function deval
    ! DEVAL

    function d2val(Ss, X, Xs, S, N)
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        integer :: N
        real :: Ss
        real :: d2val
        real, dimension(N) :: S, X, Xs
        intent (in) N, S, Ss, X, Xs
        !
        ! Local variables
        !
        real :: cx1, cx2, ds, t
        integer :: i, ilow, imid
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !--------------------------------------------------
        !     Calculates d2X/dS2(SS)                       |
        !     XS array must have been calculated by SPLINE |
        !--------------------------------------------------
        ilow = 1
        i = N
        !
        do while (i - ilow>1)
            !
            imid = (i + ilow) / 2
            if (Ss<S(imid)) then
                i = imid
            else
                ilow = imid
            endif
        enddo
        !
        ds = S(i) - S(i - 1)
        t = (Ss - S(i - 1)) / ds
        cx1 = ds * Xs(i - 1) - X(i) + X(i - 1)
        cx2 = ds * Xs(i) - X(i) + X(i - 1)
        d2val = (6. * t - 4.) * cx1 + (6. * t - 2.0) * cx2
        d2val = d2val / ds**2
    end function d2val
    ! D2VAL

    function curv(Ss, X, Xs, Y, Ys, S, N)
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        integer :: N
        real :: Ss
        real :: curv
        real, dimension(N) :: S, X, Xs, Y, Ys
        intent (in) N, S, Ss, X, Xs, Y, Ys
        !
        ! Local variables
        !
        real :: cx1, cx2, cy1, cy2, ds, sd, t, xd, xdd, yd, ydd
        integer :: i, ilow, imid
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !-----------------------------------------------
        !     Calculates curvature of splined 2-D curve |
        !     at S = SS                                 |
        !                                               |
        !     S        arc length array of curve        |
        !     X, Y     coordinate arrays of curve       |
        !     XS,YS    derivative arrays                |
        !              (calculated earlier by SPLINE)   |
        !-----------------------------------------------
        !
        ilow = 1
        i = N
        !
        do while (i - ilow>1)
            !
            imid = (i + ilow) / 2
            if (Ss<S(imid)) then
                i = imid
            else
                ilow = imid
            endif
        enddo
        !
        ds = S(i) - S(i - 1)
        t = (Ss - S(i - 1)) / ds
        !
        cx1 = ds * Xs(i - 1) - X(i) + X(i - 1)
        cx2 = ds * Xs(i) - X(i) + X(i - 1)
        xd = X(i) - X(i - 1) + (1.0 - 4.0 * t + 3.0 * t * t) * cx1 + t * (3.0 * t - 2.0) * cx2
        xdd = (6.0 * t - 4.0) * cx1 + (6.0 * t - 2.0) * cx2
        !
        cy1 = ds * Ys(i - 1) - Y(i) + Y(i - 1)
        cy2 = ds * Ys(i) - Y(i) + Y(i - 1)
        yd = Y(i) - Y(i - 1) + (1.0 - 4.0 * t + 3.0 * t * t) * cy1 + t * (3.0 * t - 2.0) * cy2
        ydd = (6.0 * t - 4.0) * cy1 + (6.0 * t - 2.0) * cy2
        !
        sd = sqrt(xd * xd + yd * yd)
        sd = max(sd, 0.001 * ds)
        !
        curv = (xd * ydd - yd * xdd) / sd**3
        !
    end function curv
    ! CURV

    function curvs(Ss, X, Xs, Y, Ys, S, N)
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        integer :: N
        real :: Ss
        real :: curvs
        real, dimension(N) :: S, X, Xs, Y, Ys
        intent (in) N, S, Ss, X, Xs, Y, Ys
        !
        ! Local variables
        !
        real :: bot, cx1, cx2, cy1, cy2, dbotdt, ds, dtopdt, sd, t, top, xd, xdd, xddd, yd, ydd, yddd
        integer :: i, ilow, imid
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !-----------------------------------------------
        !     Calculates curvature derivative of        |
        !     splined 2-D curve at S = SS               |
        !                                               |
        !     S        arc length array of curve        |
        !     X, Y     coordinate arrays of curve       |
        !     XS,YS    derivative arrays                |
        !              (calculated earlier by SPLINE)   |
        !-----------------------------------------------
        !
        ilow = 1
        i = N
        !
        do while (i - ilow>1)
            !
            imid = (i + ilow) / 2
            if (Ss<S(imid)) then
                i = imid
            else
                ilow = imid
            endif
        enddo
        !
        ds = S(i) - S(i - 1)
        t = (Ss - S(i - 1)) / ds
        !
        cx1 = ds * Xs(i - 1) - X(i) + X(i - 1)
        cx2 = ds * Xs(i) - X(i) + X(i - 1)
        xd = X(i) - X(i - 1) + (1.0 - 4.0 * t + 3.0 * t * t) * cx1 + t * (3.0 * t - 2.0) * cx2
        xdd = (6.0 * t - 4.0) * cx1 + (6.0 * t - 2.0) * cx2
        xddd = 6.0 * cx1 + 6.0 * cx2
        !
        cy1 = ds * Ys(i - 1) - Y(i) + Y(i - 1)
        cy2 = ds * Ys(i) - Y(i) + Y(i - 1)
        yd = Y(i) - Y(i - 1) + (1.0 - 4.0 * t + 3.0 * t * t) * cy1 + t * (3.0 * t - 2.0) * cy2
        ydd = (6.0 * t - 4.0) * cy1 + (6.0 * t - 2.0) * cy2
        yddd = 6.0 * cy1 + 6.0 * cy2
        !
        sd = sqrt(xd * xd + yd * yd)
        sd = max(sd, 0.001 * ds)
        !
        bot = sd**3
        dbotdt = 3.0 * sd * (xd * xdd + yd * ydd)
        !
        top = xd * ydd - yd * xdd
        dtopdt = xd * yddd - yd * xddd
        !
        curvs = (dtopdt * bot - dbotdt * top) / bot**2
        !
    end function curvs
    ! CURVS

    subroutine sinvrt(Si, Xi, X, Xs, S, N)
        use i_xfoil, only: show_output
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        integer :: N
        real :: Si, Xi
        real, dimension(N) :: S, X, Xs
        intent (in) N, S, X, Xi, Xs
        intent (inout) Si
        !
        ! Local variables
        !
        real :: ds, res, resp, sisav
        integer :: iter
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !-------------------------------------------------------
        !     Calculates the "inverse" spline function S(X).    |
        !     Since S(X) can be multi-valued or not defined,    |
        !     this is not a "black-box" routine.  The calling   |
        !     program must pass via SI a sufficiently good      |
        !     initial guess for S(XI).                          |
        !                                                       |
        !     XI      specified X value       (input)           |
        !     SI      calculated S(XI) value  (input,output)    |
        !     X,XS,S  usual spline arrays     (input)           |
        !                                                       |
        !-------------------------------------------------------
        !
        sisav = Si
        !
        do iter = 1, 10
            res = seval(Si, X, Xs, S, N) - Xi
            resp = deval(Si, X, Xs, S, N)
            ds = -res / resp
            Si = Si + ds
            if (abs(ds / (S(N) - S(1)))<1.0E-5) return
        enddo
        if (show_output) write (*, *) 'SINVRT: spline inversion failed. Input value returned.'
        Si = sisav
        !
    end subroutine sinvrt
    ! SINVRT

    subroutine scalc(X, Y, S, N)
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        integer :: N
        real, dimension(N) :: S, X, Y
        intent (in) N, X, Y
        intent (inout) S
        !
        ! Local variables
        !
        integer :: i
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !----------------------------------------
        !     Calculates the arc length array S  |
        !     for a 2-D array of points (X,Y).   |
        !----------------------------------------
        !
        S(1) = 0.
        do i = 2, N
            S(i) = S(i - 1) + sqrt((X(i) - X(i - 1))**2 + (Y(i) - Y(i - 1))**2)
        enddo
        !
    end subroutine scalc
    ! SCALC

    subroutine splnxy(X, Xs, Y, Ys, S, N)
        use i_xfoil, only: show_output
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! PARAMETER definitions
        !
        integer, parameter :: KMAX = 32
        !
        ! Dummy arguments
        !
        integer :: N
        real, dimension(N) :: S, X, Xs, Y, Ys
        intent (inout) S
        !
        ! Local variables
        !
        real :: cx1, cx2, cy1, cy2, ds, dx, dy, serr, sint, sint1, sint2, t
        integer :: i, ipass, k, kk, npass
        real, dimension(0:KMAX) :: xt, yt
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! PARAMETER definitions
        !
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !-----------------------------------------
        !     Splines 2-D shape X(S), Y(S), along |
        !     with true arc length parameter S.   |
        !-----------------------------------------
        !
        kk = KMAX
        npass = 10
        !
        !---- set first estimate of arc length parameter
        call scalc(X, Y, S, N)
        !
        !---- spline X(S) and Y(S)
        call segspl(X, Xs, S, N)
        call segspl(Y, Ys, S, N)
        !
        !---- re-integrate true arc length
        do ipass = 1, npass
            !
            serr = 0.
            !
            ds = S(2) - S(1)
            do i = 2, N
                dx = X(i) - X(i - 1)
                dy = Y(i) - Y(i - 1)
                !
                cx1 = ds * Xs(i - 1) - dx
                cx2 = ds * Xs(i) - dx
                cy1 = ds * Ys(i - 1) - dy
                cy2 = ds * Ys(i) - dy
                !
                xt(0) = 0.
                yt(0) = 0.
                do k = 1, kk - 1
                    t = float(k) / float(kk)
                    xt(k) = t * dx + (t - t * t) * ((1.0 - t) * cx1 - t * cx2)
                    yt(k) = t * dy + (t - t * t) * ((1.0 - t) * cy1 - t * cy2)
                enddo
                xt(kk) = dx
                yt(kk) = dy
                !
                sint1 = 0.
                do k = 1, kk
                    sint1 = sint1 + sqrt((xt(k) - xt(k - 1))**2 + (yt(k) - yt(k - 1))**2)
                enddo
                !
                sint2 = 0.
                do k = 2, kk, 2
                    sint2 = sint2 + sqrt((xt(k) - xt(k - 2))**2 + (yt(k) - yt(k - 2))**2)
                enddo
                !
                sint = (4.0 * sint1 - sint2) / 3.0
                !
                if (abs(sint - ds)>abs(serr)) serr = sint - ds
                !
                if (i<N) ds = S(i + 1) - S(i)
                !
                S(i) = S(i - 1) + sqrt(sint)
            enddo
            !
            serr = serr / (S(N) - S(1))
            if (show_output) write (*, *) ipass, serr
            !
            !------ re-spline X(S) and Y(S)
            call segspl(X, Xs, S, N)
            call segspl(Y, Ys, S, N)
            !
            if (abs(serr)<1.0E-7) return
            !
        enddo
        !
    end subroutine splnxy
    ! SPLNXY

    subroutine segspl(X, Xs, S, N)
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        integer :: N
        real, dimension(N) :: S, X, Xs
        intent (in) N
        !
        ! Local variables
        !
        integer :: iseg, iseg0, nseg
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !-----------------------------------------------
        !     Splines X(S) array just like SPLINE,      |
        !     but allows derivative discontinuities     |
        !     at segment joints.  Segment joints are    |
        !     defined by identical successive S values. |
        !-----------------------------------------------
        !
        if (S(1)==S(2)) stop 'SEGSPL:  First input point duplicated'
        if (S(N)==S(N - 1)) stop 'SEGSPL:  Last  input point duplicated'
        !
        iseg0 = 1
        do iseg = 2, N - 2
            if (S(iseg)==S(iseg + 1)) then
                nseg = iseg - iseg0 + 1
                call splind(X(iseg0), Xs(iseg0), S(iseg0), nseg, -999.0, -999.0)
                iseg0 = iseg + 1
            endif
        enddo
        !
        nseg = N - iseg0 + 1
        call splind(X(iseg0), Xs(iseg0), S(iseg0), nseg, -999.0, -999.0)
        !
    end subroutine segspl
    ! SEGSPL

    subroutine segspld(X, Xs, S, N, Xs1, Xs2)
        implicit none
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        integer :: N
        real :: Xs1, Xs2
        real, dimension(N) :: S, X, Xs
        intent (in) N
        !
        ! Local variables
        !
        integer :: iseg, iseg0, nseg
        !
        !*** End of declarations rewritten by SPAG
        !
        !
        !*** Start of declarations rewritten by SPAG
        !
        ! Dummy arguments
        !
        !
        ! Local variables
        !
        !
        !*** End of declarations rewritten by SPAG
        !
        !-----------------------------------------------
        !     Splines X(S) array just like SPLIND,      |
        !     but allows derivative discontinuities     |
        !     at segment joints.  Segment joints are    |
        !     defined by identical successive S values. |
        !-----------------------------------------------
        !
        if (S(1)==S(2)) stop 'SEGSPL:  First input point duplicated'
        if (S(N)==S(N - 1)) stop 'SEGSPL:  Last  input point duplicated'
        !
        iseg0 = 1
        do iseg = 2, N - 2
            if (S(iseg)==S(iseg + 1)) then
                nseg = iseg - iseg0 + 1
                call splind(X(iseg0), Xs(iseg0), S(iseg0), nseg, Xs1, Xs2)
                iseg0 = iseg + 1
            endif
        enddo
        !
        nseg = N - iseg0 + 1
        call splind(X(iseg0), Xs(iseg0), S(iseg0), nseg, Xs1, Xs2)
        !
    end subroutine segspld
    ! SEGSPL
end module m_spline


      SUBROUTINE iau_TPSTV ( XI, ETA, V0, V )
*
*  - - - - - - - - - -
*   i a u _ T P S T V
*  - - - - - - - - - -
*
*  In the tangent plane projection, given the star's rectangular
*  coordinates and the direction cosines of the tangent point, solve
*  for the direction cosines of the star.
*
*  This routine is part of the International Astronomical Union's
*  SOFA (Standards of Fundamental Astronomy) software collection.
*
*  Status:  support routine.
*
*  Given:
*     XI,ETA    d       rectangular coordinates of star image (Note 2)
*     V0        d(3)    tangent point's direction cosines (Note 4)
*
*  Returned:
*     V         d(3)    star's direction cosines
*
*  1) The tangent plane projection is also called the "gnomonic
*     projection" and the "central projection".
*
*  2) The eta axis points due north in the adopted coordinate system.
*     If the direction cosines represent observed (RA,Dec), the tangent
*     plane coordinates (xi,eta) are conventionally called the "standard
*     coordinates".  If the direction cosines are with respect to a
*     right-handed triad, (xi,eta) are also right-handed.  The units of
*     (xi,eta) are, effectively, radians at the tangent point.
*
*  3) The method used is to complete the star vector in the (xi,eta)
*     based triad and normalize it, then rotate the triad to put the
*     tangent point at the pole with the x-axis aligned to zero
*     longitude.  Writing (a0,b0) for the celestial spherical
*     coordinates of the tangent point, the sequence of rotations is
*     (b0-pi/2) around the x-axis followed by (-a0-pi/2) around the
*     z-axis.
*
*  4) If vector V0 is not of unit length, the returned vector V will
*     be wrong.
*
*  5) If vector V0 points at a pole, the returned vector V will be
*     based on the arbitrary assumption that the longitude coordinate
*     of the tangent point is zero.
*
*  6) This routine is a member of the following set:
*
*         spherical       vector       solve for
*
*         iau_TPXES      iau_TPXEV      xi,eta
*         iau_TPSTS    > iau_TPSTV <     star
*         iau_TPORS      iau_TPORV      origin
*
*  References:
*
*     Calabretta M.R. & Greisen, E.W., 2002, "Representations of
*     celestial coordinates in FITS", Astron.Astrophys. 395, 1077
*
*     Green, R.M., "Spherical Astronomy", Cambridge University Press,
*     1987, Chapter 13.
*
*  This revision:   2018 January 2
*
*  SOFA release 2020-07-21
*
*  Copyright (C) 2020 IAU SOFA Board.  See notes at end.
*
*-----------------------------------------------------------------------

      IMPLICIT NONE

      DOUBLE PRECISION XI, ETA, V0(3), V(3)

      DOUBLE PRECISION X, Y, Z, R, F

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

*  Tangent point.
      X = V0(1)
      Y = V0(2)
      Z = V0(3)

*  Deal with polar case.
      R = SQRT(X*X+Y*Y)
      IF ( R .EQ. 0D0 ) THEN
         R = 1D-20
         X = R
      END IF

*  Star vector length to tangent plane.
      F = SQRT(1D0+XI*XI+ETA*ETA)

*  Apply the transformation and normalize.
      V(1) = ( X - (XI*Y+ETA*X*Z) / R ) / F
      V(2) = ( Y + (XI*X-ETA*Y*Z) / R ) / F
      V(3) = ( Z + ETA*R ) / F

*  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


PROGRAM KPP_ROOT_Driver

  USE KPP_ROOT_Model
  USE KPP_ROOT_Initialize, ONLY: Initialize

  IMPLICIT NONE

!~~~> No. of Stochastic events per simulation snaphot
      INTEGER :: Nevents
!~~~> No. of Stochastic tau-steps simulation snaphot
      INTEGER :: Nsteps
!~~~> No. of Molecules
      INTEGER :: NmlcV(NVAR), NmlcF(NFIX)
!~~~> Random numbers
      REAL :: r1, r2
!~~~> Local variables
      INTEGER :: i
      KPP_REAL :: T, Tau, SCT(NREACT)

!~~~~> Initialize and prescribe volume and no. of events
      CALL Initialize()
!      Volume  = 1000.0d0
      Nevents = 5000
      Nsteps = 10
      Tau = (TEND-TSTART)/100.0
!~~~~~~~~~~~~~~~~

!~~~> Translate initial values from conc. to NmlcVules
      NmlcV(1:NVAR) = INT(Volume*VAR(1:NVAR))
      NmlcF(1:NFIX) = INT(Volume*FIX(1:NFIX))
!~~~> Compute the stochastic reaction rates
      CALL Update_RCONST()
      CALL StochasticRates( RCONST, Volume, SCT )

!~~~> Save initial data
      OPEN(10, file='KPP_ROOT_stochastic.dat')
      WRITE(10,992) T, (NmlcV(i),i=1,NVAR)

!~~~> TIME loop starts
      T = TSTART
kron: DO WHILE (T < TEND)

        WRITE(6,991) T,(SPC_NAMES(i),NmlcV(i), i=1,NVAR)

!~~~> Choose here one of the following time-stepping routines
        CALL Gillespie(Nevents, T, SCT, NmlcV, NmlcF)
!        CALL TauLeap(Nsteps, Tau, T, SCT, NmlcV, NmlcF)

        WRITE(10,992) T, (NmlcV(i),i=1,NVAR)

      END DO kron
!~~~> TIME loop ends

      WRITE(6,991) T,(SPC_NAMES(i), NmlcV(i), i=1,NVAR)

      CLOSE(10)

991   FORMAT('T=',F12.3,20(A,'=',I5,'; '))
992   FORMAT(E24.14,200(1X,I12))

END PROGRAM KPP_ROOT_Driver


program roman_numerals

  implicit none

  write (*, '(a)') roman (2009)
  write (*, '(a)') roman (1666)
  write (*, '(a)') roman (3888)

contains

function roman (n) result (r)

  implicit none
  integer, intent (in) :: n
  integer, parameter   :: d_max = 13
  integer              :: d
  integer              :: m
  integer              :: m_div
  character (32)       :: r
  integer,        dimension (d_max), parameter :: d_dec = &
    & (/1000, 900, 500, 400, 100, 90, 50, 40, 10, 9, 5, 4, 1/)
  character (32), dimension (d_max), parameter :: d_rom = &
    & (/'M ', 'CM', 'D ', 'CD', 'C ', 'XC', 'L ', 'XL', 'X ', 'IX', 'V ', 'IV', 'I '/)

  r = ''
  m = n
  do d = 1, d_max
    m_div = m / d_dec (d)
    r = trim (r) // repeat (trim (d_rom (d)), m_div)
    m = m - d_dec (d) * m_div
  end do

end function roman

end program roman_numerals