! a test problem comparing direct GS relaxation vs a simple 2 level MG relaxation
! to distill the basic idea and show the potential for speed up and agreement in the solutions.

! solves L phi = A sin (k * x * 2pi/L) where L is a discritised laplacian in 1D
! and compares to an analytical solution.

! this same problem was considered with more  exposition (such as  figures, which I can't be bothered with
! - this just spits out L2 norms vs the analytical) on  Lubos Brida's (particle in cell consulting) blog
! at https://www.particleincell.com/2018/multigrid-solver/ . He also has some python code on that website that may be
! of interest.

module shared_data

  implicit none

  integer :: out_unit = 10
  integer, parameter :: num = selected_real_kind(p=15)
  real(num), parameter :: pi2 = 8.0_num * atan(1.0_num)

  integer :: nx, ix
  real(num) :: x_min,x_max, dx

  real(num) :: A, k

  real(num), dimension(:), allocatable :: xc ! x at cell centers
  real(num), dimension(:), allocatable :: phi ! phi at cell centers
  real(num), dimension(:), allocatable :: f ! f at cell centers

  contains

  subroutine initial_setup ! allocate and initialise

    ! assume nx is divisible by 2
    if (mod(nx,2) /= 0) then
      print *,'idiot'
      STOP
    endif

    allocate(xc(0:nx+1)) ! 1 ghost cell either side needed
    allocate(f(1:nx))
    allocate(phi(0:nx+1))

    dx = (x_max - x_min) / real(nx,num)

    xc(0) = x_min - dx/2.0_num
    do ix = 1,nx+1
      xc(ix) = xc(ix-1) + dx
    enddo

    do ix = 1, nx ! choose f from RHS of  d^2/dx^2(phi) = f
      f(ix) = A * sin(k * pi2 * xc(ix) / (x_max-x_min))
    enddo

  end subroutine initial_setup

end module shared_data

module diagnostics

  use shared_data

  implicit none

  public :: check_vs_analytic

  contains

  subroutine check_vs_analytic

    real(num) :: analytic, diff, C1, C2, d
    real(num) :: L2

    d = x_max-x_min
    C1 = A * d / k / pi2
    C2 = - C1 * d

    L2 = 0.0_num
    do ix = 1, nx
      analytic = - A * sin(k * pi2 * xc(ix) / d) * (d / k / pi2)**2 &
                & + C1 * xc(ix) + C2
      diff = phi(ix) - analytic
      L2 = L2 + abs(diff)**2
    enddo
    L2 = sqrt(L2 / real(nx,num))

    print *, '****** L2 on computed vs analytic',L2

  end subroutine check_vs_analytic

end module diagnostics

module gauss_seidel

  use shared_data

  implicit none
  private
  public :: solve_gs

  contains

  subroutine solve_gs(myphi,rhs,tol)

    real(num), dimension(:), allocatable, intent(inout) :: myphi
    real(num), dimension(:), allocatable, intent(in) :: rhs
    real(num), intent(in) :: tol
    real(num) :: L_myphi ! discritised laplacian of myphi
    real(num) :: L2_old, L2 ! norms
    integer :: ir

    real(num) :: start, finish

    call cpu_time(start)

    L2_old = 1e6_num

    ir = 0

    call bcs(myphi)

    do
      ir = ir + 1

      do ix = 1, nx
        myphi(ix) = 0.5_num * (myphi(ix-1) + myphi(ix+1) - dx**2 * rhs(ix))
      enddo

      call bcs(myphi)

      L2 = 0.0_num
      do ix = 1, nx
        L_myphi = ( myphi(ix-1) - 2.0_num * myphi(ix) + myphi(ix+1) ) / dx**2
        L2 = L2 + abs(rhs(ix) - L_myphi)**2
      enddo
      L2 = sqrt(L2 / real(nx,num))

      ! verbose
!      print *,'step',ir,'L2',L2

      ! exit criterion
      if (abs(L2-L2_old) <= tol) exit
!      if (ir >= 50) exit
      L2_old = L2
    enddo

    call cpu_time(finish)

    print *, '*** solve_gs completed:'
    print *, '****** steps:',ir
    print '(" ****** cpu_time: ",f20.3," seconds.")',finish-start
    print *, '****** tolerance (L2-L2_old <=tol for exit)',tol
    print *, '****** L2 norm on residual', L2

  end subroutine solve_gs

  subroutine bcs(myphi)

    real(num), dimension(:), allocatable, intent(inout) :: myphi

    ! Neumann (dphi/dx =0 at x=0) BC
    ! i.e. zero gradient
    myphi(0) = myphi(1)
    ! Dirichlet (phi = 0 at x = x_max)
    myphi(nx+1) = -myphi(nx)

  end subroutine bcs

end module gauss_seidel

module mg_2level

  use shared_data

  implicit none
  private
  public :: solve_mg

  contains

  subroutine solve_mg(myphi,rhs,tol,ncoarse,nfine)

    real(num), dimension(:), allocatable, intent(inout) :: myphi
    real(num), dimension(:), allocatable, intent(in) :: rhs
    real(num), intent(in) :: tol
    integer, intent(in) :: ncoarse, nfine

    real(num), dimension(1:nx) :: residual
    real(num), dimension(1:nx/2) :: residual_c!oarse
    real(num), dimension(:), allocatable :: epsi

    real(num) :: Lap ! Laplacian
    real(num) :: L2, L2_old ! norms

    integer :: nsteps ! number of steps through the algoritm (main do loop)
    integer :: nop ! number of iterative operations through a 1D array
    integer :: c ! counter for sub iterations

    integer :: ixc !coarse x index

    real(num) :: start, finish

    call cpu_time(start)

    ! initialise a coarse grid and data
    if (.not.(allocated(epsi))) allocate(epsi(0:nx/2+1))
    epsi = 0.0_num
    residual = 0.0_num

    ! the main cycle

    L2_old = 1e6_num ! init as huge
    nsteps = 0
    nop = 0
    do ! main do
      nsteps = nsteps + 1

      ! 3 iterations of GS relaxation on initial (finest) grid
      do c = 1, ncoarse
        nop = nop + 1
        call bcs(myphi)
        do ix = 1, nx
          myphi(ix) = 0.5_num * (myphi(ix-1) + myphi(ix+1) - dx**2 * rhs(ix))
        enddo
      enddo

      ! see if converged to tolerance on this finest grid and exit
      ! if satisfied

      call bcs(myphi)

      L2 = 0.0_num
      do ix = 1, nx
        Lap = ( myphi(ix-1) - 2.0_num * myphi(ix) + myphi(ix+1) ) / dx**2
        residual(ix) = Lap - rhs(ix)
      enddo
      L2 = sqrt(sum(abs(residual)**2)/real(nx,num))

      if (abs(L2-L2_old) <= tol) exit
      L2_old = L2

      ! restrict residue to a coarse grid
      ix = 1
      do ixc = 1, nx/2
        residual_c(ixc) = 0.5_num * (residual(ix) + residual(ix+1))
        ix = ix + 2
      enddo

      ! GS relaxation on the coarse grid to estimate a solution to
      ! Lap * epsi = residual_c

      do c = 1, nfine
        if (mod(c,2)==0) nop = nop + 1 !only do every 2 steps since coarse array is half the size of fine
        call coarse_bcs(epsi)
        do ixc = 1, nx /2
          epsi(ixc) = 0.5_num * (epsi(ixc-1) + epsi(ixc+1) - (dx*2.0_num)**2 * residual_c(ixc))
        enddo
      enddo

      ! prolongation of epsi to update the estimate of phi on the fine grid
      ix = 1
      do ixc = 1, nx/2
        ! direct injection - replace with 2nd order method down line?
        ! phi => phi - epsi
        myphi(ix) = myphi(ix) - epsi(ixc)
        myphi(ix+1) = myphi(ix+1) - epsi(ixc)
        ix = ix + 2
      enddo

    enddo !main do

    call cpu_time(finish)

    ! output

    print *, '*** solve_mg completed:'
    print *, '****** ncycles:',nsteps
    print *, '****** relative number of iterative steps through array(1:nx)',nop
    print '(" ****** cpu_time: ",f20.3," seconds.")',finish-start
    print *, '****** tolerance (L2-L2_old <=tol for exit)',tol
    print *, '****** ncoarse iterations per cycle',ncoarse
    print *, '****** nfine iterations per cycle',nfine
    print *, '****** L2 norm on residual', L2

    ! deallocate the coarse grid

  end subroutine solve_mg

  subroutine bcs(myphi)

    real(num), dimension(:), allocatable, intent(inout) :: myphi

    ! Neumann (dphi/dx =0 at x=0) BC
    ! i.e. zero gradient
    myphi(0) = myphi(1)
    ! Dirichlet (phi = 0 at x = x_max)
    myphi(nx+1) = -myphi(nx)

  end subroutine bcs

  subroutine coarse_bcs(epsi)

    real(num), dimension(:), allocatable, intent(inout) :: epsi

    ! since solving a residual eqn, always homogeneous
    ! for this test case, the fine BCs (i.e. bcs on phi) are also homogeneous
    ! so these are the same

    ! exept upper limit nx => nx/2 . In other words this subroutine
    ! exists purely for this reason -> should do a more compact solution

    ! Neumann (dphi/dx =0 at x=0) BC
    ! i.e. zero gradient
    epsi(0) = epsi(1)
    ! Dirichlet (phi = 0 at x = x_max)
    epsi(nx/2+1) = -epsi(nx/2)

  end subroutine coarse_bcs

end module mg_2level

program poission_2dgrid_test

  use shared_data
  use diagnostics
  use gauss_seidel
  use mg_2level

  implicit none

  ! user parameters here

  x_min = 0.0_num
  x_max = 1.0_num
  nx = 128

  A = 10.0_num
  k = 4.0_num

  call initial_setup

  ! Some output to remind you of your parameters
  print *,''
  print *,'Multilevel relaxation tests on Poission eqn'
  print *,'*******************'
  print *,'nx =',nx

  ! Two Level Multigrid
  print *,''
  print *, 'Two-level Multi Grid Relaxation'
  print *,'*******************'
  print *, '***Start MG2 relaxation'
  phi = 0.0_num
  call solve_mg(myphi = phi, rhs = f, tol = 1e-16_num, ncoarse = 3, nfine =50)
  print *, '*** Comparing to analytical sln'
  call check_vs_analytic

  ! GS Relaxation (for comparisons sake)
  print *,''
  print *,'Gauss-Seidel Iteration'
  print *,'*******************'
  print *, '***Start GS relaxation'
  phi = 0.0_num
  call solve_gs(myphi = phi, rhs = f, tol = 1e-16_num)
  print *, '*** Comparing to analytical sln'
  call check_vs_analytic

end program poission_2dgrid_test


      FUNCTION dpythag(a,b)
      DOUBLE PRECISION a,b,dpythag
      DOUBLE PRECISION absa,absb
      absa=abs(a)
      absb=abs(b)
      if(absa.gt.absb)then
        dpythag=absa*sqrt(1.0d0+(absb/absa)**2)
      else
        if(absb.eq.0.0d0)then
          dpythag=0.0d0
        else
          dpythag=absb*sqrt(1.0d0+(absa/absb)**2)
        endif
      endif
      return
      END

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


 SUBROUTINE GAUSSLAT(JMAX,SLAT,WLAT)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! $Revision: 71314 $
!
! SUBPROGRAM:  GAUSSLAT   COMPUTE GAUSSIAN LATITUDES
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 92-04-16
!
! ABSTRACT: COMPUTES COSINES OF COLATITUDE AND GAUSSIAN WEIGHTS
!   ON THE GAUSSIAN LATITUDES.  THE GAUSSIAN LATITUDES ARE AT
!   THE ZEROES OF THE LEGENDRE POLYNOMIAL OF THE GIVEN ORDER.
!
! PROGRAM HISTORY LOG:
!   92-04-16  IREDELL
!   97-10-20  IREDELL  INCREASED PRECISION
! 1999-08-18  IREDELL  CALLED SPLAT
!
! USAGE:    CALL GAUSSLAT(JMAX,SLAT,WLAT)
!
!   INPUT ARGUMENT LIST:
!     JMAX     - INPUT NUMBER OF LATITUDES.
!
!   OUTPUT ARGUMENT LIST:
!     SLAT     - REAL (K) COSINES OF COLATITUDE.
!     WLAT     - REAL (K) GAUSSIAN WEIGHTS.
!
! SUBPROGRAMS CALLED:
!   SPLAT        COMPUTE LATITUDE FUNCTIONS
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER,           INTENT(IN   ) :: JMAX
!
 REAL,              INTENT(OUT  ) :: SLAT(JMAX),WLAT(JMAX)
!
 CALL SPLAT(4,JMAX,SLAT,WLAT)
!
 RETURN
 END SUBROUTINE GAUSSLAT


!file: lasso.f90
subroutine lasso(beta, & !output
                 V, u, lambda, & !inputs :: data and parameter
                 ths, max_iter, & !inputs, optional :: opt. parameters
                 dim_beta) !inputs :: dimensions
    implicit none

    !inputs :: dimensions
    integer, intent(in) :: dim_beta

    !inputs :: data and parameter
    real(8), dimension(dim_beta, dim_beta), intent(in) :: V
    real(8), dimension(dim_beta), intent(in) :: u, lambda

    !inputs :: opt. parameters
    integer, intent(in) :: max_iter
    real(8), intent(in) :: ths

!f2py integer optional, intent(in) :: max_iter = 100
!f2py real(8) optional, intent(in) :: ths = 0.001

    !in/outputs
    real(8), dimension(dim_beta) :: beta

!f2py intent(inplace) beta

    ! local variables
    integer :: i, q
    real(8), dimension(dim_beta) :: beta_last

    do i = 1, max_iter
        beta_last = beta

        do q = 1, dim_beta
            beta(q) = u(q) - dot_product(V(q,:q-1), beta(:q-1)) &
                      - dot_product(V(q,q+1:), beta(q+1:))
            beta(q) = sign(max(abs(beta(q))-lambda(q), 0.0) / V(q,q), &
                           beta(q))
        end do

        if (maxval(abs(beta - beta_last)) < ths) then
            exit
        end if
    end do

end subroutine lasso


! =====================================================================
! subroutine MKTR
!
! This subroutine constructs the radial kinetic energy terms that
! appear in the finite difference operators.
! ---------------------------------------------------------------------
      subroutine MKTR(nR,dR,R,RH,TRL,TRD,TRU)
      implicit none

      integer :: nR
      double precision :: dR
      double precision :: R(nR)
      double precision :: RH(nR+1)
      double precision :: TRL(nR-1)
      double precision :: TRD(nR)
      double precision :: TRU(nR-1)

      integer :: i

      do i = 1, nR-1
         TRL(i) = 0.5d0*RH(i+1)/(R(i+1)*dR**2)
         TRD(i) = 0.5d0*(RH(i)+RH(i+1))/(R(i)*dR**2)
         TRU(i) = 0.5d0*RH(i+1)/(R(i)*dR**2)
      enddo
      TRD(nR) = 0.5d0*(RH(nR)+RH(nR+1))/(R(nR)*dR**2)

      return
      end
! =====================================================================


program  problem_2
    integer a
    integer b
    integer c
    integer total
    a = 1
    b = 1
    c = 0
    total = 0
    do while (c < 4000000)
        c = a + b
        a = b
        b = c

        if (MODULO(c, 2) == 0) then
            total = total + c
        end if
    end do
    print *,"Problem 2:", total
end program problem_2


program ch1307
    ! Wave Breaking on an Offshore Reef
    implicit none

    real :: hr, hlow, high, half, xl
    real :: xh, xm, d
    real, parameter :: tol = 1.e-6
    print *, ' Give reformed wave height, &
        &and water depth'
    read *, hr, d

    hlow = hr
    high = hlow*2.
    xl = f(hlow,hr,d)
    xh = f(high,hr,d)

    do while ((xl*xh)>=0.)
        high = high*2.
        xh = f(high,hr,d)
    end do

    do
        half = (hlow+high)*.5
        xm = f(half,hr,d)
        if ((xl*xm)<0.) then
            xh = xm
            high = half
        else
            xl = xm
            hlow = half
        end if
        if (abs(high-hlow)<=tol) exit
    end do
    print *, ' Incident Wave Height Lies Between'
    print *, hlow, ' and ', high, ' metres'
contains
    real function f(a, b, c)
        implicit none

        real, intent(in) :: a, b, c

        f = a*(1.-.8*exp(-.6*c/a))-b
    end function
end program


PROGRAM test_cube_root
USE quadruple_precision
IMPLICIT NONE

TYPE (quad)          :: x, lhs, rhs, diff
REAL (dp)            :: half = 0.5_dp, small = EPSILON(half), r
INTEGER, ALLOCATABLE :: seed(:)
INTEGER              :: k, i

!     Set the random number seed.

CALL RANDOM_SEED(size=k)
ALLOCATE (seed(k))
CALL RANDOM_SEED(get=seed)
WRITE(*, *)'Old random number seeds: ', seed

WRITE(*, '(1x, a, i4, a)') 'Enter ', k, ' integers as random number seeds: '
READ(*, *) seed
CALL RANDOM_SEED(put=seed)

DO i = 1, 20
  CALL RANDOM_NUMBER(x%hi)
  CALL RANDOM_NUMBER(r)
  x%hi = (x%hi - half) / r
  x%lo = x%hi * small
  lhs = cube_root(x)
  IF (x%hi >= 0._dp) THEN
    rhs = EXP( LOG(x) / 3._dp)
  ELSE
    rhs = - EXP( LOG(- x) / 3._dp)
  END IF
  diff = lhs - rhs
  WRITE(*, '(" lhs =", g13.5, "  Diff. =", g12.4)') lhs%hi, diff%hi
END DO

STOP

CONTAINS

FUNCTION cube_root(y) RESULT(x)
!     Calculates the cube root of y in quadruple-precision.

! Programmer : Alan Miller, CSIRO Mathematical Information Sciences
! e-mail: alan @ mel.dms.csiro.au   WWW: http://www.mel.dms.csiro.au/~alan
! Fax: (+61) 3-9545-8080

! Latest revision - 6 December 1996

IMPLICIT NONE
TYPE (quad), INTENT(IN) :: y
TYPE (quad)             :: x

!     Local variables
TYPE (quad) :: f, xsq
REAL (dp)   :: one_third = 0.3333333333333333_dp

!     First approximation is the double-precision cube root.
!     Only one iteration is necessary.

x%hi = SIGN(ABS(y%hi) ** one_third, y%hi)

! Put f(x) = x**3 - y
! Then Newton's iterative method uses:
!
! new x = x - f(x) / f'(x)
!
! Halley's method uses:
!
! new x = x - f / (f' - 0.5 * f * f'' / f')
!
! In this case
!
! new x = x - x * f / (3.x**3 - f)

x%lo = 0._dp
xsq  = exactmul2(x%hi, x%hi)
f    = x * xsq - y
x    = x - x * f / (3._dp * x * xsq - f)

RETURN
END FUNCTION cube_root

END PROGRAM test_cube_root


!**********************************************************************************************************
!
!                                            A Ñ O   B I S I E S T O
!
!       Program:         BISIESTO (sin mod)
!       Autor:           David Duran
!       Fecha:           28 de junio del 2021
!       Lenguaje:        Fortran-90
!       Versión:         0.2
!       Descripción:     Este programa determina si un año es bisiesto o no sin hacer uso de
!                        la función MODULO.
!
!**********************************************************************************************************

program bisiesto
    implicit none
    real:: yy
    real:: div1, redondeo1, residuo1
    real:: div2, redondeo2, residuo2
    real:: div3, redondeo3, residuo3

    print*, ""
    print*, "Este programa determina si un año es bisiesto o no."
    print*, "Para salir del bucle, pulse CTRL + C."

    do !Bucle, use CTRL + C en caso desea salir de él

    print*, ""
    print*, "Inserte un año."
    print*, ""
    read*, yy

    !for 4
    div1 = yy / 4
    redondeo1 = nint(div1)
    residuo1 = div1 - redondeo1

    !for 400
    div2 = yy / 400
    redondeo2 = nint(div2)
    residuo2 = div2 - redondeo2

    !for 100
    div3 = yy / 100
    redondeo3 = nint(div3)
    residuo3 = div3 - redondeo3

    if (residuo3 .EQ. 0 .AND. residuo2 .EQ. 0) then
        print*, "!Cuidado, este es un año BISIESTO!"

    else if(residuo1 .EQ. 0 .AND. residuo3 .NE. 0) then
            print*, "!Cuidado, este es un año BISIESTO!"
    else
        print*, "Felizmente NO es BISIESTO."
    end if

    end do
end program bisiesto


MODULE OMSAO_median_module

  USE OMSAO_precision_module, ONLY: i4, r8

  IMPLICIT NONE

CONTAINS

  ! --------------------------------------------------------------------
  ! REAL FUNCTION  Median() :
  !    This function receives an array X of N entries, copies its value
  !    to a local array Temp(), sorts Temp() and computes the median.
  !    The returned value is of REAL type.
  ! --------------------------------------------------------------------

  REAL (KIND=r8) FUNCTION median (n, x)

    IMPLICIT  NONE

    ! ---------------
    ! Input variables
    ! ---------------
    INTEGER (KIND=i4),                INTENT (IN) :: n
    REAL    (KIND=r8), DIMENSION (n), INTENT (IN) :: x

    ! ---------------
    ! Local variables
    ! ---------------
    REAL    (KIND=r8), DIMENSION (n) :: tmp

    tmp(1:n) = x(1:n)               ! make a copy

    CALL sort(n, tmp)               ! sort the copy
    IF (MOD(n,2) == 0) THEN           ! compute the median
       median = (tmp(n/2) + tmp(n/2+1)) / 2.0_r8
    ELSE
       median = tmp(n/2+1)
    END IF

    RETURN
  END FUNCTION  median

  ! --------------------------------------------------------------------
  ! REAL FUNCTION  WeightMean() :
  !    This function receives an array X of N entries, computes the
  !    standard deviation, and subsequently the mean of those values
  !    that lie within M sigma of the regular mean values
  !    The returned value is of REAL type.
  ! --------------------------------------------------------------------

  REAL (KIND=r8) FUNCTION weightmean (n, x, m)

    IMPLICIT  NONE

    ! ---------------
    ! Input variables
    ! ---------------
    INTEGER (KIND=i4),                INTENT (IN) :: n, m
    REAL    (KIND=r8), DIMENSION (n), INTENT (IN) :: x

    ! ---------------
    ! Local variables
    ! ---------------
    REAL    (KIND=r8) :: mean, smean, sdev
    INTEGER (KIND=i4) :: i, k

    weightmean = 0.0_r8

    IF ( n < 0 ) RETURN

    mean = SUM(x(1:n)) / REAL(n, KIND=r8)
    sdev = 0.0_r8
    DO i = 1, n
       sdev = sdev + (x(i)-mean)*(x(i)-mean)
    END DO
    sdev = SQRT( sdev ) / REAL(n, KIND=r8)

    smean = 0.0_r8 ; k = 0
    DO i = 1, n
       IF ( ( x(i) >= mean - REAL(m,KIND=r8)*sdev) .AND. &
            ( x(i) <= mean + REAL(m,KIND=r8)*sdev)        ) THEN
          smean = smean + x(i)
          k     = k + 1
       END IF
    END DO
    IF ( k > 0 ) smean = smean / REAL(k, KIND=r8)

    weightmean = smean

    RETURN
  END FUNCTION  weightmean

  ! --------------------------------------------------------------------
  ! INTEGER FUNCTION  FindMinimum():
  !    This function returns the location of the minimum in the section
  ! between Start and End.
  ! --------------------------------------------------------------------

  INTEGER (KIND=i4) FUNCTION FindMinimumPosition(n, x, start, end) RESULT (minpos)

    IMPLICIT  NONE

    ! ---------------
    ! Input variables
    ! ---------------
    INTEGER (KIND=i4),                 INTENT (IN) :: n
    REAL    (KIND=r8), DIMENSION(1:n), INTENT (IN) :: x
    INTEGER (KIND=i4),                 INTENT (IN) :: start, end

    ! ---------------
    ! Result variable
    ! ---------------
    INTEGER (KIND=i4) :: location

    ! ---------------
    ! Local variables
    ! ---------------
    REAL    (KIND=r8) :: minimum
    INTEGER (KIND=i4) :: i

    minimum  = x(start)             ! assume the first is the min
    location = start                ! record its position
    DO i = start+1, end             ! start with next elements
       IF ( x(i) < minimum ) THEN   !   if x(i) less than the min?
          minimum  = x(i)           !      Yes, a new minimum found
          location = i              !      record its position
       END IF
    END DO

    minpos = location

  END FUNCTION  FindMinimumPosition

  ! --------------------------------------------------------------------
  ! SUBROUTINE  Swap():
  !    This subroutine swaps the values of its two formal arguments.
  ! --------------------------------------------------------------------

  SUBROUTINE  swap(a, b)

    IMPLICIT  NONE

    ! ------------------
    ! Modified variables
    ! ------------------
    REAL (KIND=r8), INTENT (INOUT) :: a, b

    ! ---------------
    ! Local variables
    ! ---------------
    REAL (KIND=r8) :: tmp

    tmp = a
    a   = b
    b   = tmp

    RETURN
  END SUBROUTINE  swap

  ! --------------------------------------------------------------------
  ! SUBROUTINE  Sort():
  !    This subroutine receives an array x() and sorts it
  !    into ascending order.
  ! --------------------------------------------------------------------

  SUBROUTINE  sort(n, x)

    IMPLICIT  NONE

    ! --------------
    ! Input variable
    ! --------------
    INTEGER (KIND=i4), INTENT (IN) :: n

    ! -----------------
    ! Modified variable
    ! -----------------
    REAL (KIND=r8), DIMENSION(n), INTENT (INOUT) :: x

    ! ---------------
    ! Local variables
    ! ---------------
    INTEGER :: i, minpos

    DO i = 1, n-1                                   ! except for the last
       minpos = FindMinimumPosition ( n, x, i, n )  ! find min from this to last
       CALL swap(x(i), x(minpos))                   ! swap this and the minimum
    END DO

    RETURN
  END SUBROUTINE  sort

END MODULE  OMSAO_median_module


C++------------------------------------------------------------------
C	PROGRAM ELLIPTIC_INT
C Program to check Quinn's results for shell profiles
C (Hernquist and Quinn 1988)
C
C JLP
C Version of 20-06-90
C--------------------------------------------------------------------
	PROGRAM ELLIPTIC_INT
	IMPLICIT REAL*8 (A-H,O-Z)
	PARAMETER (NPTS=100)
	REAL*4 RAD(NPTS),SURF_BRIGHT(NPTS)

C Tests :
	PRINT *,' XM ?'
	READ(5,*) XM
	XK=ELLIPTIC_K(XM)
	PRINT *,' ELLIPTIC_K :',XK
	XE=ELLIPTIC_E(XM)
	PRINT *,' ELLIPTIC_E :',XE

C Computing the profile:
	D=1.
	STEP=D/REAL(NPTS)

C My version :
	DO I=1,NPTS
	  X=REAL(I)*STEP
	  XM=(D-X)/(D+X)
	  SURF_BRIGHT(I)=-2.*X*ELLIPTIC_K(XM)/DSQRT(D+X)
     1	+ 2.*DSQRT(D+X)*ELLIPTIC_E(XM)
	  RAD(I)=X
	END DO

C Quinn's version :
C	DO I=1,100
C	  X=REAL(I)*STEP
C	  XM=(D-X)/(D+X)
C	  SURF_BRIGHT(I)=-2.*X*ELLIPTIC_K(XM)/DSQRT(D+X)
C     1	+ 2.*DSQRT(D+X)*ELLIPTIC_E(XM)*D/X
C	  RAD(I)=X
C	END DO

C Writing on the output file:
	OPEN(1,FILE='elliptic.dat',STATUS='unknown')
	WRITE(1,*)NPTS
	DO I=1,100
	  WRITE(1,*)RAD(I),SURF_BRIGHT(I)
	END DO
	CLOSE(1)

	PRINT *,' Output curve in "elliptic.dat"'
	END
C--------------------------------------------------------------------
C Real*8 function to approximate
C Complete Elliptic integral of the First Kind
C (Abramotwitz et Stegun) (+/- 3. E-05)
C--------------------------------------------------------------------
	REAL*8 FUNCTION ELLIPTIC_K(XM)
	IMPLICIT REAL*8 (A-H,O-Z)
	REAL*8 A(0:2),B(0:2)
	DATA A/1.3862944,0.1119723,0.0725296/
	DATA B/0.5,0.1213478,0.0288729/

	XM1=1.-XM
	ELLIPTIC_K=(A(0)+A(1)*XM1+A(2)*XM1*XM1)
     1	+ (B(0)+B(1)*XM1+B(2)*XM1*XM1)*DLOG(1./XM1)

	RETURN
	END
C--------------------------------------------------------------------
C Real*8 function to approximate
C Complete Elliptic integral of the Second Kind
C (Abramotwitz et Stegun)  (+/- 4.E-05)
C--------------------------------------------------------------------
	REAL*8 FUNCTION ELLIPTIC_E(XM)
	IMPLICIT REAL*8 (A-H,O-Z)
	REAL*8 A(1:2),B(1:2)
	DATA A/0.4630151,0.1077812/
	DATA B/0.2452727,0.0412496/

	XM1=1.-XM
	ELLIPTIC_E=(1.+A(1)*XM1+A(2)*XM1*XM1)
     1	+ (B(1)*XM1+B(2)*XM1*XM1)*DLOG(1./XM1)

	RETURN
	END


!> the problem is to determine the values of x(1), x(2), ..., x(9),
!>  which solve the system of tridiagonal equations.
!>
!>  (3-2*x(1))*x(1)           -2*x(2)                   = -1
!>          -x(i-1) + (3-2*x(i))*x(i)         -2*x(i+1) = -1, i=2-8
!>                              -x(8) + (3-2*x(9))*x(9) = -1
program example_hybrd1

    use minpack_module, only: wp, hybrd1, dpmpar, enorm
    use iso_fortran_env, only: nwrite => output_unit

    implicit none

    integer,parameter :: n = 9
    integer,parameter :: lwa = (n*(3*n+13))/2

    integer :: j, info
    real(wp) :: tol, fnorm
    real(wp) :: x(n), fvec(n), wa(lwa)

    !> The following starting values provide a rough solution.
    x = -1.0_wp

    !> Set tol to the square root of the machine precision.
    !>  unless high precision solutions are required,
    !>  this is the recommended setting.
    tol = sqrt(dpmpar(1))

    call hybrd1(fcn, n, x, fvec, tol, info, wa, lwa)
    fnorm = enorm(n, fvec)

    write (nwrite, '(5x,a,d15.7//5x,a,16x,i10//5x,a//(5x,3d15.7))') &
            "FINAL L2 NORM OF THE RESIDUALS", fnorm, &
            "EXIT PARAMETER", info, &
            "FINAL APPROXIMATE SOLUTION", x

    !> Results obtained with different compilers or machines
    !>  may be slightly different.
    !>
    !>> FINAL L2 NORM OF THE RESIDUALS  0.1192636D-07
    !>>
    !>> EXIT PARAMETER                         1
    !>>
    !>> FINAL APPROXIMATE SOLUTION
    !>>
    !>>  -0.5706545D+00 -0.6816283D+00 -0.7017325D+00
    !>>  -0.7042129D+00 -0.7013690D+00 -0.6918656D+00
    !>>  -0.6657920D+00 -0.5960342D+00 -0.4164121D+00

contains

    !> Subroutine fcn for hybrd1 example.
    subroutine fcn(n, x, fvec, iflag)

        implicit none
        integer, intent(in) :: n
        integer, intent(inout) :: iflag
        real(wp), intent(in) :: x(n)
        real(wp), intent(out) :: fvec(n)

        integer :: k
        real(wp) :: temp, temp1, temp2

        real(wp),parameter :: zero = 0.0_wp
        real(wp),parameter :: one = 1.0_wp
        real(wp),parameter :: two = 2.0_wp
        real(wp),parameter :: three = 3.0_wp

        do k = 1, n
            temp = (three - two*x(k))*x(k)
            temp1 = zero
            if (k /= 1) temp1 = x(k - 1)
            temp2 = zero
            if (k /= n) temp2 = x(k + 1)
            fvec(k) = temp - temp1 - two*temp2 + one
        end do

    end subroutine fcn

end program example_hybrd1


module stdlib_linalg
  !!Provides a support for various linear algebra procedures
  !! ([Specification](../page/specs/stdlib_linalg.html))
  use stdlib_kinds, only: sp, dp, xdp, qp, &
    int8, int16, int32, int64
  use stdlib_optval, only: optval
  implicit none
  private

  public :: diag
  public :: eye
  public :: trace
  public :: outer_product

  interface diag
    !! version: experimental
    !!
    !! Creates a diagonal array or extract the diagonal elements of an array
    !! ([Specification](../page/specs/stdlib_linalg.html#description))
      !
      ! Vector to matrix
      !
      module function diag_rdp(v) result(res)
        real(dp), intent(in) :: v(:)
        real(dp) :: res(size(v),size(v))
      end function diag_rdp
      module function diag_cdp(v) result(res)
        complex(dp), intent(in) :: v(:)
        complex(dp) :: res(size(v),size(v))
      end function diag_cdp
      module function diag_iint32(v) result(res)
        integer(int32), intent(in) :: v(:)
        integer(int32) :: res(size(v),size(v))
      end function diag_iint32
      module function diag_rdp_k(v,k) result(res)
        real(dp), intent(in) :: v(:)
        integer, intent(in) :: k
        real(dp) :: res(size(v)+abs(k),size(v)+abs(k))
      end function diag_rdp_k
      module function diag_cdp_k(v,k) result(res)
        complex(dp), intent(in) :: v(:)
        integer, intent(in) :: k
        complex(dp) :: res(size(v)+abs(k),size(v)+abs(k))
      end function diag_cdp_k
      module function diag_iint32_k(v,k) result(res)
        integer(int32), intent(in) :: v(:)
        integer, intent(in) :: k
        integer(int32) :: res(size(v)+abs(k),size(v)+abs(k))
      end function diag_iint32_k

      !
      ! Matrix to vector
      !
      module function diag_rdp_mat(A) result(res)
        real(dp), intent(in) :: A(:,:)
        real(dp) :: res(minval(shape(A)))
      end function diag_rdp_mat
      module function diag_cdp_mat(A) result(res)
        complex(dp), intent(in) :: A(:,:)
        complex(dp) :: res(minval(shape(A)))
      end function diag_cdp_mat
      module function diag_iint32_mat(A) result(res)
        integer(int32), intent(in) :: A(:,:)
        integer(int32) :: res(minval(shape(A)))
      end function diag_iint32_mat
      module function diag_rdp_mat_k(A,k) result(res)
        real(dp), intent(in) :: A(:,:)
        integer, intent(in) :: k
        real(dp) :: res(minval(shape(A))-abs(k))
      end function diag_rdp_mat_k
      module function diag_cdp_mat_k(A,k) result(res)
        complex(dp), intent(in) :: A(:,:)
        integer, intent(in) :: k
        complex(dp) :: res(minval(shape(A))-abs(k))
      end function diag_cdp_mat_k
      module function diag_iint32_mat_k(A,k) result(res)
        integer(int32), intent(in) :: A(:,:)
        integer, intent(in) :: k
        integer(int32) :: res(minval(shape(A))-abs(k))
      end function diag_iint32_mat_k
  end interface

  ! Matrix trace
  interface trace
    !! version: experimental
    !!
    !! Computes the trace of a matrix
    !! ([Specification](../page/specs/stdlib_linalg.html#description_2))
      module procedure trace_rdp
      module procedure trace_cdp
      module procedure trace_iint32
  end interface

  ! Outer product (of two vectors)
  interface outer_product
    !! version: experimental
    !!
    !! Computes the outer product of two vectors, returning a rank-2 array
    !! ([Specification](../page/specs/stdlib_linalg.html#description_3))
      pure module function outer_product_rdp(u, v) result(res)
        real(dp), intent(in) :: u(:), v(:)
        real(dp) :: res(size(u),size(v))
      end function outer_product_rdp
      pure module function outer_product_cdp(u, v) result(res)
        complex(dp), intent(in) :: u(:), v(:)
        complex(dp) :: res(size(u),size(v))
      end function outer_product_cdp
      pure module function outer_product_iint32(u, v) result(res)
        integer(int32), intent(in) :: u(:), v(:)
        integer(int32) :: res(size(u),size(v))
      end function outer_product_iint32
  end interface outer_product

contains

    !> Version: experimental
    !>
    !> Constructs the identity matrix.
    !> ([Specification](../page/specs/stdlib_linalg.html#eye-construct-the-identity-matrix))
    pure function eye(dim1, dim2) result(result)

        integer, intent(in) :: dim1
        integer, intent(in), optional :: dim2
        integer(int8), allocatable :: result(:, :)

        integer :: dim2_
        integer :: i

        dim2_ = optval(dim2, dim1)
        allocate(result(dim1, dim2_))

        result = 0_int8
        do i = 1, min(dim1, dim2_)
            result(i, i) = 1_int8
        end do

    end function eye

      function trace_rdp(A) result(res)
        real(dp), intent(in) :: A(:,:)
        real(dp) :: res
        integer :: i
        res = 0
        do i = 1, minval(shape(A))
          res = res + A(i,i)
        end do
      end function trace_rdp
      function trace_cdp(A) result(res)
        complex(dp), intent(in) :: A(:,:)
        complex(dp) :: res
        integer :: i
        res = 0
        do i = 1, minval(shape(A))
          res = res + A(i,i)
        end do
      end function trace_cdp
      function trace_iint32(A) result(res)
        integer(int32), intent(in) :: A(:,:)
        integer(int32) :: res
        integer :: i
        res = 0
        do i = 1, minval(shape(A))
          res = res + A(i,i)
        end do
      end function trace_iint32

end module stdlib_linalg


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  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                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
!     Subroutine trvsph is used to demonstrate vector data transfer between a coarse
!     ten degree equally spaced grid and a higher resolution T42 Global Spectral
!     Gaussian grid.
!
!     Ten Degree Grid (Mathematical Spherical Coordinates)
!
!     The equally spaced vector data, given in mathematical spherical
!     coordinates,  is stored in 19 X 36 colatitude-longitude arrays (ue, ve).  The
!     colatitudinal values are stored north to south with increasing colatitude
!     subscript values.  ue is the east longitudinal component and ve is the
!     colatitudinal component of the vector.
!
!     Gaussian Grid (Geophysical Spherical Coordinates)
!
!     The T42 Gaussian grid vector data is in geophysical spherical coordinates.
!     It is stored in 128 X 64 longitude-latitude arrays (ug, vg).  Values are
!     stored south to north with increasing latitude subscript value.  ug
!     is the longitudinal component and vg is the latitudinal componenet of the
!     vector data.
!
!     For testing purposes we use an analytic vector field (u, v).  Let t and p
!     be colatitude and longitude and x=sin(t)cos(p), y=sint(t)*sin(p), z=cos(t)
!     be the cartesian coordinates restricted to the sphere in mathematical
!     coordinates. We derive the vector field (u, v) from the stream function
!     S and velocity function P given by
!
!               y    -z           x    z
!          S = e  + e  ,     P = e  + e
!
!     The corresponding vector field has the form
!
!                x          -z          y
!          u = -e sin(p) + e  sin(t) + e cos(t)sin(p)
!
!                y          z          x
!          v = -e cos(p) - e sin(t) + e cos(t)cos(p)
!
!
!     in mathematical spherical coordinates.  Values in geophysical
!     coordinates can be obtained by negating v.
!
!     In the code below, (ue, ve) is set equal to (u, v) and trvsph is used to
!     transfer (ue, ve) to (ug, vg).  (ug, vg) is then compared with (u, v) in
!     geophysical coordinates on the T42 Gaussian grid.  Finally, trvsph is
!     used to transfer (ug, vg) back to (ue, vg) and this is compared with (u, v).
!     Output from executing the test program on separate platforms with 32 bit
!     and 64 bit floating point arithmetic is listed below.  The minimum required
!     saved and unsaved workspace lengths were predetermined by an earlier call
!     trvsph with nlon_reg=36, nlat_reg=19, nlon_gau=128, nlat_gau=64, lsave=0, lwork=0 and printout
!     of lsvmin and lwkmin.
!
!
! **********************************************************************
!
!     OUTPUT FROM EXECUTING CODE IN THIS FILE
!
! **********************************************************************
!
!      EQUALLY SPACED TO GAUSSIAN GRID TRANSFER
!      trvsph input arguments:
!      intl =  0
!      igrid_reg(1) = -1   igrid_reg(2) =  1
!      nlon_reg =  36   nlat_reg =  19
!      ive =  1
!      igrid_gau(1) =  2   igrid_gau(2) =  0
!      nlon_gau = 128   nlat_gau =  64
!      ivg =  0
!      lsave =   21814   lwork =   75173
!
!      trvsph output:
!      ier =        0  lsvmin =   21792  lwkmin =   75173
! ***  32 BIT FLOATING POINT ARITHMETIC
!      least squares error in u =  0.307E-06
!      least squares error in v =  0.272E-06
! ***  64 BIT FLOATING POINT ARITHMETIC
!      least squares error in u =  0.841E-12
!      least squares error in v =  0.603E-12
!
!      GAUSSIAN TO EQUALLY SPACED GRID TRANSFER
!      trvsph input arguments:
!      intl =  0
!      igrid_gau(1) =  2   igrid_gau(2) =  0
!      nlon_gau = 128   nlat_gau =  64
!      ivg =  0
!      igrid_reg(1) = -1   igrid_reg(2) =  1
!      nlon_reg =  36   nlat_reg =  19
!      ive =  1
!      lsave =   21814   lwork =   75173
!
!      trvsph output:
!      ier =        0  lsvmin =   21814  lwkmin =   75173
! ***  32 BIT FLOATING POINT ARITHMETIC
!      least squares error in u =  0.374E-06
!      least squares error in v =  0.364E-06
! ***  64 BIT FLOATING POINT ARITHMETIC
!      least squares error in u =  0.170E-12
!      least squares error in v =  0.161E-12
!
! **********************************************************************
!
!     END OF OUTPUT ... CODE FOLLOWS
!
! **********************************************************************
program testrvsph

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use spherepack

    ! Explicit typing only
    implicit none

    ! Set grid sizes with parameter statements
    integer(ip), parameter :: NLAT_GAU = 64, NLON_GAU = 128
    integer(ip), parameter :: NLAT_REG = 19, NLON_REG = 36

    ! Dimension and type data arrays and grid vectors and internal variables
    real(wp) :: u_reg(NLAT_REG, NLON_REG), v_reg(NLAT_REG, NLON_REG)
    real(wp) :: u_gau(NLON_GAU, NLAT_GAU), v_gau(NLON_GAU, NLAT_GAU)
    real(wp) :: theta_gau(NLAT_GAU)
    real(wp) :: gaussian_latitudes(NLAT_GAU), gaussian_weights(NLAT_GAU)
    integer(ip) :: igrid_reg(2), igrid_gau(2), ivec_reg, ivec_gau
    real(wp) :: dlat_reg, dlon_reg, dlon_gau
    real(wp) :: theta, phi, cosp, sinp, cost, sint, x, y, z
    real(wp) :: erru2, errv2, ex, ey, ez, emz, uee, vee
    integer(ip) :: i, j, ib, intl, error_flag
    real(wp), parameter :: ZERO = 0.0_wp

    ! Set equally spaced grid increments
    dlat_reg = PI/(NLAT_REG-1)
    dlon_reg = TWO_PI/NLON_REG
    dlon_gau = TWO_PI/NLON_GAU

    ! Set initial call flag
    intl = 0

    ! flag (ue, ve) grid as north to south equally spaced
    igrid_reg(1) = -1

    ! flag (ue, ve) as nlat_reg by nlon_reg arrays
    igrid_reg(2) = 1
    !     flag ve as colatitude component of vector
    ivec_reg = 1

    ! flag (ug, vg) as south to north gaussian
    igrid_gau(1) = 2

    ! flag (ug, vg) as nlon_gau by nlat_gau arrays
    igrid_gau(2) = 0

    ! flag vg as latitude component of vector
    ivec_gau = 0

    ! Set vector data in (ue, ve)
    do  j=1, NLON_REG
        phi = real(j - 1, kind=wp)*dlon_reg
        cosp = cos(phi)
        sinp = sin(phi)
        do i=1, NLAT_REG
            theta = real(i - 1, kind=wp)*dlat_reg
            cost = cos(theta)
            sint = sin(theta)
            x = sint*cosp
            y = sint*sinp
            z = cost
            ex = exp(x)
            ey = exp(y)
            ez = exp(z)
            emz = exp(-z)
            v_reg(i, j) = ex*cost*cosp-ey*cosp-ez*sint
            u_reg(i, j) = -ex*sinp + emz*sint + ey*cost*sinp
        end do
    end do

    ! print trvsph input arguments
    write (stdout, 100) intl, igrid_reg(1), igrid_reg(2), NLON_REG, NLAT_REG, ivec_reg, &
        igrid_gau(1), igrid_gau(2), NLON_GAU, NLAT_GAU, ivec_gau
100 format(//' equally spaced to gaussian vector grid transfer ' , &
        /' input arguments: ' , &
        /' intl = ', i2, &
        /' igrid_reg(1) = ', i2, 2x, ' igrid_reg(2) = ', i2, &
        /' nlon_reg = ', i3, 2x, ' nlat_reg = ', i3, &
        /' ivec_reg = ', i2, &
        /' igrid_gau(1) = ', i2, 2x, ' igrid_gau(2) = ', i2, &
        /' nlon_gau = ', i3, 2x, ' nlat_gau = ', i3, &
        /' ivec_gau = ', i2)

    ! Transfer  (u_reg, v_reg) to (u_gau, v_gau)
    call trvsph(intl, igrid_reg, NLON_REG, NLAT_REG, ivec_reg, u_reg, v_reg, &
        igrid_gau, NLON_GAU, NLAT_GAU, ivec_gau, u_gau, v_gau, error_flag)

    if (error_flag == 0) then
        ! Compute nlat_gau-many gaussian colatitude points and
        ! set with south to north orientation in theta_gau
        call compute_gaussian_latitudes_and_weights( &
            NLAT_GAU, gaussian_latitudes, gaussian_weights, error_flag)

        ! Reverse array
        theta_gau = gaussian_latitudes(NLAT_GAU:1:-1)

        ! Compute the least squares error in (ug, vg)
        ! by comparing with exact geophysical vector
        errv2 = ZERO
        erru2 = ZERO
        do  j=1, NLON_GAU
            phi = real(j - 1, kind=wp) * dlon_gau
            cosp = cos(phi)
            sinp = sin(phi)
            do i=1, NLAT_GAU
                theta = theta_gau(i)
                cost = cos(theta)
                sint = sin(theta)
                x = sint*cosp
                y = sint*sinp
                z = cost
                ex = exp(x)
                ey = exp(y)
                ez = exp(z)
                emz = exp(-z)
                vee = -ex*cost*cosp+ey*cosp+ez*sint
                uee = -ex*sinp + emz*sint + ey*cost*sinp
                erru2 = erru2 + (u_gau(j, i)-uee)**2
                errv2 = errv2 + (v_gau(j, i)-vee)**2
            end do
        end do
        erru2 = sqrt(erru2/(NLON_GAU*NLAT_GAU))
        errv2 = sqrt(errv2/(NLON_GAU*NLAT_GAU))
        call print_least_squared_error(erru2, errv2)
    end if

    ! Now transfer (u_gau, v_gau) back to (u_reg, v_reg)
    u_reg = ZERO
    v_reg = ZERO

    write (stdout, 101) intl, igrid_gau(1), igrid_gau(2), NLON_GAU, NLAT_GAU, ivec_gau, &
        igrid_reg(1), igrid_reg(2), NLON_REG, NLAT_REG, ivec_reg
101 format(//' gaussian to equally spaced vector grid transfer ' , &
        /' input arguments: ' , &
        /' intl = ', i2, &
        /' igrid_gau(1) = ', i2, 2x, ' igrid_gau(2) = ', i2, &
        /' nlon_gau = ', i3, 2x, ' nlat_gau = ', i3, &
        /' ivec_gau = ', i2, &
        /' igrid_reg(1) = ', i2, 2x, ' igrid_reg(2) = ', i2, &
        /' nlon_reg = ', i3, 2x, ' nlat_reg = ', i3, &
        /' ivec_reg = ', i2)

    call trvsph(intl, igrid_gau, NLON_GAU, NLAT_GAU, ivec_gau, u_gau, v_gau, &
        igrid_reg, NLON_REG, NLAT_REG, ivec_reg, u_reg, v_reg, error_flag)

    if (error_flag == 0) then
        !
        !     compute the least squares error in (ue, ve)
        !     by comparing with exact mathematical vector
        !
        errv2 = ZERO
        erru2 = ZERO
        do  j=1, NLON_REG
            phi = real(j-1, kind=wp) * dlon_reg
            cosp = cos(phi)
            sinp = sin(phi)
            do i=1, NLAT_REG
                theta = real(i - 1, kind=wp) * dlat_reg
                cost = cos(theta)
                sint = sin(theta)
                x = sint*cosp
                y = sint*sinp
                z = cost
                ex = exp(x)
                ey = exp(y)
                ez = exp(z)
                emz = exp(-z)
                vee =  ex*cost*cosp-ey*cosp-ez*sint
                uee = -ex*sinp + emz*sint + ey*cost*sinp
                erru2 = erru2 + (u_reg(i, j)-uee)**2
                errv2 = errv2 + (v_reg(i, j)-vee)**2
            end do
        end do
        erru2 = sqrt(erru2/(NLON_REG*NLAT_REG))
        errv2 = sqrt(errv2/(NLON_REG*NLAT_REG))
        call print_least_squared_error(erru2, errv2)
    end if

contains

    subroutine print_least_squared_error(erru2, errv2)

        ! Dummy arguments
        real(wp), intent(in) :: erru2, errv2

        write (stdout, '(2(a,e10.3/))') &
            ' least squares error in u = ', erru2, &
            ' least squares error in v = ', errv2

    end subroutine print_least_squared_error

end program testrvsph


c=======================================================================
c
c     subroutine PEMRBM
c
c     Mean Reversion process (Arithmetic Ornstein-Uhlenbeck)
c
c           dS(t) = -theta*(S(t)-mu)dt + sigma*dW(t)
c
c     Method: Euler discretization of SDE
c
c                S(1)   = S
c                a      = exp(- delta*dt )
c                b      = sqrt((1 - exp(- 2*delta*dt))/(2*delta))
c                S(t+1) = S(t)*a + mu*(1 - a) + sigma*b*N(0,1)
c
c                with dt = T/(N-1)
c
c-----------------------------------------------------------------------
      SUBROUTINE pemrbm ( T, N, S, theta, mu, sigma, y, info )
c-----------------------------------------------------------------------
c
c     INPUT :
c            T      : time (days, months, years)                 integer
c            N      : number of sub-division(s)                  integer
c            S      : initial value                               double
c            theta  : velocity of the reversion                   double
c            mu     : mean reversion                              double
c            sigma  : process volatility                          double
c
c     OUTPUT :
c            y      : generated step (N)                          double
c            info   : diagnostic information                     integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER N, T, info
      DOUBLE PRECISION S, theta, mu, sigma, y(*)
c
c     local variables
      INTEGER i, M
      DOUBLE PRECISION dt, a, b
c
c     external functions
      DOUBLE PRECISION rn
      EXTERNAL rn
c
c     intrinsic function
      INTRINSIC DFLOAT, EXP, SQRT
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
c
c     discetization step
      M = N - 1
      dt = (DFLOAT(T)/M)
c
c     coefficients
      a = EXP( - theta * dt)
      b = SQRT((1. - EXP(- 2.* theta * dt))/(2. * theta))
c
c     mean-reversion process
      y(1) = S
      DO i = 1,M
         y(i + 1) = (a*y(i)) + (mu*(1. - a)) + (b*sigma*rn())
      ENDDO
c
      RETURN
      END


module OUTILS

implicit none

    integer, parameter :: vp = kind(1.d0)

contains

!------------------------------------------------------------------------
!-      Outil de calcul: Matrices de rotations (sens trigo)             -
!------------------------------------------------------------------------
subroutine rotationX(vecteur,ax)

implicit none

! IN/OUT variables
        real (kind=vp), dimension(3) :: vecteur
        real (kind=vp) :: ax

! local variables
        real (kind=vp), dimension(3,3) :: Rx

!initialisation de la matrice de rotation autour de l'axe X

        Rx(1,:)=(/  1._vp ,       0._vp ,      0._vp  /)
        Rx(2,:)=(/  0._vp ,    COSD(ax) ,  -SIND(ax)  /)
        Rx(3,:)=(/  0._vp ,    SIND(ax) ,   COSD(ax)  /)

        vecteur=MATMUL(Rx,vecteur)

end subroutine rotationX

subroutine rotationY(vecteur,ay)

implicit none

! IN/OUT variables
        real (kind=vp), dimension(3) :: vecteur
        real (kind=vp) :: ay

! local variables
        real (kind=vp), dimension(3,3) :: Ry

!initialisation de la matrice de rotation autour de l'axe Y

        Ry(1,:)=(/  COSD(ay) ,   0._vp ,   SIND(ay)  /)
        Ry(2,:)=(/     0._vp ,   1._vp ,      0._vp  /)
        Ry(3,:)=(/ -SIND(ay) ,   0._vp ,   COSD(ay)  /)

        vecteur=MATMUL(Ry,vecteur)

end subroutine rotationY

subroutine rotationZ(vecteur,az)

implicit none

! IN/OUT variables
        real (kind=vp), dimension(3) :: vecteur
        real (kind=vp) :: az

! local variables
        real (kind=vp), dimension(3,3) :: Rz

!initialisation de la matrice de rotation autour de l'axe Z

        Rz(1,:)=(/  COSD(az) ,  -SIND(az) ,   0._vp  /)
        Rz(2,:)=(/  SIND(az) ,   COSD(az) ,   0._vp  /)
        Rz(3,:)=(/     0._vp ,      0._vp ,   1._vp  /)

        vecteur=MATMUL(Rz,vecteur)

end subroutine rotationZ

subroutine rotation_deg(axe,vecteur,a)

implicit none

! IN/OUT variables
        real (kind=vp), dimension(3) :: axe
        real (kind=vp), dimension(3) :: vecteur
        real (kind=vp) :: a

! local variables
        real (kind=vp), dimension(3,3) :: R

!l'axe doit etre normalise
        axe=axe/norme(axe)

!initialisation de la matrice de rotation autour de l'axe Z

        R(1,1)=axe(1)**2._vp+COSD(a)*(1._vp-axe(1)**2._vp)
        R(1,2)=axe(1)*axe(2)*(1._vp-COSD(a))-axe(3)*SIND(a)
        R(1,3)=axe(1)*axe(3)*(1._vp-COSD(a))+axe(2)*SIND(a)
        R(2,1)=axe(1)*axe(2)*(1._vp-COSD(a))+axe(3)*SIND(a)
        R(2,2)=axe(2)**2._vp+COSD(a)*(1._vp-axe(2)**2._vp)
        R(2,3)=axe(2)*axe(3)*(1._vp-COSD(a))-axe(1)*SIND(a)
        R(3,1)=axe(1)*axe(3)*(1._vp-COSD(a))-axe(2)*SIND(a)
        R(3,2)=axe(2)*axe(3)*(1._vp-COSD(a))+axe(1)*SIND(a)
        R(3,3)=axe(3)**2._vp+COSD(a)*(1._vp-axe(3)**2._vp)

        vecteur=MATMUL(R,vecteur)

end subroutine rotation_deg

subroutine rotation_rad(axe,vecteur,a)

implicit none

! IN/OUT variables
        real (kind=vp), dimension(3) :: axe
        real (kind=vp), dimension(3) :: vecteur
        real (kind=vp) :: a

! local variables
        real (kind=vp), dimension(3,3) :: R

!l'axe doit etre normalise
        axe=axe/norme(axe)

!initialisation de la matrice de rotation autour de l'axe Z

        R(1,1)=axe(1)**2._vp+COS(a)*(1._vp-axe(1)**2._vp)
        R(1,2)=axe(1)*axe(2)*(1._vp-COS(a))-axe(3)*SIN(a)
        R(1,3)=axe(1)*axe(3)*(1._vp-COS(a))+axe(2)*SIN(a)
        R(2,1)=axe(1)*axe(2)*(1._vp-COS(a))+axe(3)*SIN(a)
        R(2,2)=axe(2)**2._vp+COS(a)*(1._vp-axe(2)**2._vp)
        R(2,3)=axe(2)*axe(3)*(1._vp-COS(a))-axe(1)*SIN(a)
        R(3,1)=axe(1)*axe(3)*(1._vp-COS(a))-axe(2)*SIN(a)
        R(3,2)=axe(2)*axe(3)*(1._vp-COS(a))+axe(1)*SIN(a)
        R(3,3)=axe(3)**2._vp+COS(a)*(1._vp-axe(3)**2._vp)

        vecteur=MATMUL(R,vecteur)

end subroutine rotation_rad

!------------------------------------------------------------------------
!-      Outil de calcul: Norme d'un vecteur                             -
!------------------------------------------------------------------------
function norme(vecteur)

implicit none

! IN/OUT variables
        real (kind=vp), dimension(3) ,intent(in) :: vecteur

        real (kind=vp) :: norme

!Calcul de la norme d'un vecteur

        norme=SQRT(vecteur(1)**2._vp+vecteur(2)**2._vp+vecteur(3)**2._vp)

end function norme

!------------------------------------------------------------------------
!-      Conversion des coordonnees equatoriales d'une source en         -
!-      coordonnees instrument                                          -
!------------------------------------------------------------------------
subroutine conv_equat_to_instr(pointage,source, photon)

implicit none

! IN/OUT variables
        real (kind=vp), dimension(3) :: pointage !en radec
        real (kind=vp), dimension(2) :: source   !en radec

        real (kind=vp), dimension(3) :: photon   !en cartesien

! local variables
        real (kind=vp), dimension(3,3) :: axes_pntg
        real(kind=vp),dimension(3,3) :: matrice
        real(kind=vp),dimension(3) :: tmp
        real(kind=vp),dimension(3) :: vect_src

!coordonnees cartesiennes de chaque axe du repere instrument dans repere equatorial
    !coordonnees des axes au pointage ra=0 et dec=0
    axes_pntg(1,:)=(/ 0._vp ,  0._vp , 1._vp /)
    axes_pntg(2,:)=(/ 0._vp , -1._vp , 0._vp /)
    axes_pntg(3,:)=(/ 1._vp ,  0._vp , 0._vp /)
    !coordonnees des axes au pointage ra et dec
    call rotationZ(axes_pntg(1,:),pointage(1))
    call rotationZ(axes_pntg(2,:),pointage(1))
    call rotationZ(axes_pntg(3,:),pointage(1))
    call rotation_deg(axes_pntg(2,:),axes_pntg(1,:),pointage(2))
    call rotation_deg(axes_pntg(2,:),axes_pntg(2,:),pointage(2))
    call rotation_deg(axes_pntg(2,:),axes_pntg(3,:),pointage(2))

!calcul de la matrice de passage
    matrice(1,:)=axes_pntg(1,:)
    matrice(2,:)=axes_pntg(2,:)
    matrice(3,:)=axes_pntg(3,:)

!coordonnees de la source passee en coordonnees cart
    vect_src=cartesien(source(1),source(2))

!calcul du vecteur direction de la source dans le repere de pointage de l'instrument
    photon=MATMUL(matrice,vect_src)
    photon=-photon

end subroutine conv_equat_to_instr

function cartesien(ra,dec)
    !passage des coordonnees equatoriales (en degres) en cartesien
    real(kind=vp),intent(in) :: ra,dec
    real(kind=vp),dimension(3) :: cartesien

    cartesien(1)=COSD(dec)*COSD(ra)
    cartesien(2)=COSD(dec)*SIND(ra)
    cartesien(3)=SIND(dec)

end function cartesien

end module OUTILS


      subroutine SSFIT(XI,YI,SDI,NXY, KORDER, NC, TKNOTS, BCOEF,
     *                  SIGFAC, IERR1, LDW, W)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2000-12-03 SSFIT Krogh  Declared SDI(*) so ref. with SD(1) o.k.
c>> 1995-11-21 SSFIT Krogh  Converted from SFTRAN to Fortran 77.
c>> 1994-10-19 SSFIT Krogh  Changes to use M77CON
c>> 1994-01-31 SSFIT CLL  Add test for SDI(i) .le. 0 when SDI(1) > 0.
c>> 1993-01-12 CLL  Using SSBASD in place of _SBAS.
c>> 1992-12-15 CLL. Change error message No. 600
c>> 1992-11-18 CLL. Change order of last four arguments.
c>> 1992-11-17 CLL. Permit XI() nondecreasing or nonincreasing.
c>> 1992-10-27 C. L. Lawson, JPL
c>> 1988-03-21 C. L. Lawson, JPL
c           Least squares fit to discrete data by a spline function of
c     order KORDER.  Note that the order is one greater than the degree
c     of the polynomial pieces.  Example: The order of a cubic spline
c     is 4.
c        TKNOTS() must contain NT values, called knots, indexed from
c     1 to NT, with NT = NC+KORDER.  These values must be nondecreasing.
c     Repeated values are permitted.  The first and last KORDER-1 values
c     in TKNOTS() are needed to support the deBoor method of
c     representing splines.  The "proper fitting interval" is from
c     A = TKNOTS(KORDER) to B = TKNOTS(NT+1-KORDER).  One acceptable way
c     to set the first and last KORDER-1 knots is to set the first
c     KORDER-1 to A and the last KORDER-1 to B.
c        Continuity of the spline at knots interior to (A, B) will be of
c     order KORDER-2, unless a knot is repeated, in which case the order
c     of continuity will be decreased at that knot.
c     ------------------------------------------------------------------
C     The linear algebra methods were designed by C.L.Lawson and
c     R.J.Hanson.  The method of representing spline functions is due
c     to Carl deBoor.  References:
C     "SOLVING LEAST SQUARES PROBLEMS", by Lawson and Hanson,
C     Prentice-Hall, 1974.
c     "A PRACTICAL GUIDE TO SPLINES" by Carl de Boor,
c     Springer-Verlag, 1978.
C     Programming and later changes and corrections by Lawson,Hanson,
C     T.Lang, and D.Campbell, Sept 1968, Nov 1969, and Aug 1970.
C  1974 5/21, C.L.Lawson, Fixed bug that caused ISEG to get too big.
C     Also changed to exit immidiately if TKNOTS() array is not
C     strictly increasing.
c  1984 July 10. Modified for improved portability and to conform
c          to Fortran 77.  C. L. Lawson, JPL.
c          Added calls to the error message subrs.
c  7/23/87 CLL.  Added the IERR1 argument.
c  March 1988, CLL.  Introduced the use of deBoor's spline methods.
c  1992-11-17 CLL Permit XI() to be either nondecreasing or
c     nonincreasing.
c     ------------------------------------------------------------------
c                     SUBROUTINE ARGUMENTS
c
c  (XI(i),i=1,NXY)  [in]  Abcissas of data to be fitted.  Require
c        this data be sorted: either nondecreasing or nonincreasing.
c
c  (YI(i),i=1,NXY)  [in]  Ordinates of data to be fitted.
c
c  (SDI(i),i=1,NXY) [in]  User may use this array to assign an
c                     a priori standard deviation of error to each
c       YI(i) value.  The weighted fitting algorithm will take
c       account of these.  Optionally the user may set SDI(1) to
c       a negative value.  Then this subr will use ABS(SDI(1)) as
c       the standard deviation for each YI(i) value.  In this case
c       the SDI() array can be dimensioned SDI(1).
c       If SDI(1) = 0., the subr issues an error message and returns.
c
c  NXY  [in]  No. of data pairs, (XI(i), YI(i)), and no. of elts
c          in SDI() if SDI(1) is positive.  Require NXY .ge. 4.
c
c  KORDER  [in]  Order of the spline basis functions.  Note that the
c        polynomial degree of the spline segments is one less than the
c        order.  Example:  the order of a cubic spline is 4.
c        Require KORDER .ge. 1.  Internal arrays in subroutines used put
c        an upper limit of 20 on KORDER.
c
c  NC  [in]  No. of coefficients to be determined.  This is the
c        number of degrees of freedom for the least squares problem.
c        To have a nonsingular problem one must have
c        NXY .ge. NC, and the distribution of the interior knots
c        must not be too skewed relative to the data abcissas.
c        If singularity is detected, an error message will be
c        issued by the subr that solves the band matrix.
c
c  (TKNOTS(j),j=1,NT, where NT = NC+KORDER)  [in]  This is the deBoor
c        knot sequence for definition of the spline basis functions.
c        See remarks above.
c
c  BCOEF()  [out]  An array of length NC into which the computed
c        coefficients defining the fitted curve will be stored.  These
c        are coeffients relative to B-spline basis functions.  BCOEF(I)
c        is associated with the basis function whose support interval
c        runs from TKNOTS(I) to TKNOTS(I+KORDER).
c
c  SIGFAC  [out]  The subr sets SIGFAC to RNORM / sqrt(DOF) where
c      RNORM = sqrt( sum over i of [( (yfit(i) - YI(i))/SDI(i))**2])
C          and DOF = max(1, NXY - NC)
C
c  IERR1  [out]  Error status indicator.  Note that IERR2 comes from
c         SBACC and IERR3 comes from SBSOL.
c
c        =    0 means no errors detected.
c        =  100 means  NC .lt. 1   .or.   NC .gt. NXY
c        =  200 means  TKNOTS(I) .gt. TKNOTS(I+1)
c        =  250 means  TKNOTS(I) .ge. TKNOTS(I+KORDER)
c        =  300 means  LDW .lt. NC+2
c        =  400 means  The XI's are not sorted.
c        =  600 means  Need larger dimension LDW.
c        =  700 + IERR2 means IERR2 .ne. 0
c        =  800 + IERR2 means IERR2 .ne. 0
c        =  900 + IERR2 means IERR2 .ne. 0
c        = 1000 + IERR3 means IERR3 .ne. 0 due to singularity
c                       detected in _BSOL.
c        = 1100 means SDI(1) = zero.
c        = 1200 means SDI(1) > zero and SDI(i) .le. zero for some i.
c
c  LDW  [in]  Leading dimension of W().   Must satisfy LDW .ge. NC + 2
c          Let IXMAX denote the max no. of data abcissas, XI(i),
c          in any one knot interval, i.e. between TKNOTS(j) and
c          TKNOTS(j+1) for some j.   The subr will be more efficient
c          if LDW is at least NC + 1 + IXMAX.
c
c  W()  [scratch]  Work space dimensioned W(LDW,KORDER+1).
c     ------------------------------------------------------------------
c          Important internal variables.
c
c  ISEG     Index of current spline segment.  ISEG runs from 1 to
c           NC+1-KORDER.  The knot interval associated with index ISEG
c           is T(ISEG+KORDER-1).  Note that the union of these
c           segments is the "proper fitting interval".
c           ISEG also tells the band matrix subroutine the column index
c           of the least squares matrix with which the first col
c           of the new block of data in G() is to be associated.
c           There will be KORDER basis functions that are nonzero on
c           segment ISEG.  They are indexed from ISEG to ISEG+KORDER-1.
c  KORDP1   = KORDER+1
C  KSIZE    Number of rows in current block.
C  JPOINT   Current data pointer.
c     ------------------------------------------------------------------
c--S replaces "?": ?SFIT, ?BACC, ?BSOL, ?SBASD, ?ERV1
c     Both versions use ERMSG, IERM1, IERV1
C     Other subrs needed: DHTCC, ERMSG, ERFIN
c     ------------------------------------------------------------------
      integer I, IERR1, IERR2, IERR3, IRNOW, ISEG, ISGMAX
      integer J, JPOINT, JPT, JTPREV
      integer K, KMAX, KORDER, KORDP1, KSIZE, LDW, LEFT, NXY
      integer NBAND, NC, NT, NXYP1
      parameter(KMAX=20)
      real             BCOEF(NC), DOF, ONE, P(KMAX), RNORM
      real             SDI(*), sdijp, SIGFAC
      real             TKNOTS(NC+KORDER), W(LDW, KORDER+1), WT, WT1
      real             XI(NXY), YI(NXY), ZERO
      logical  DIRECT, USEWT1
      parameter( ONE = 1.0E0, ZERO = 0.0E0)
c     ------------------------------------------------------------------
      NBAND = KORDER
      KORDP1 = KORDER+1
      NT = NC + KORDER
      ISGMAX = NC + 1 -KORDER
      IERR1 = 0
C
C          Exit immediately if NC .lt. 1  or  NXY .lt. NC  or if the
C          knots fail to be nondecreasing.
c
      IF ( NC .lt. 1   .or.   NXY .lt. NC) THEN
         IERR1 = 100
         call IERM1('SSFIT',IERR1,0,
     *   'Require NC .ge. 1 and NXY .ge. NC', 'NC',NC,',')
         call IERV1('NXY',NXY,'.')
         go to 200
      END IF
      if(KORDER .gt. KMAX) then
         IERR1 = 150
         call IERM1('SSFIT',IERR1,0,'Require KORDER .le. KMAX.',
     *   'KORDER',KORDER,',')
         call IERV1('KMAX',KMAX,'.')
         go to 200
      end if
c
      do 10 I = 1,NT-1
        IF (TKNOTS(I) .gt. TKNOTS(I+1)) THEN
          IERR1 = 200
          call IERM1('SSFIT',IERR1,0,
     *    'Require knots, TKNOTS(I), to be nondecreasing.',
     *    'I',I,',')
          call SERV1('TKNOTS(I)',TKNOTS(I),',')
          call SERV1('TKNOTS(I+1)',TKNOTS(I+1),'.')
          go to 200
        END IF
   10 continue
c
      do 20 I = 1,NC
        IF (TKNOTS(I) .ge. TKNOTS(I+KORDER)) THEN
          IERR1 = 250
          call IERM1('SSFIT',IERR1,0,
     *    'Require TKNOTS(I) < TKNOTS(I+KORDER).',
     *    'I',I,',')
          call SERV1('TKNOTS(I)',TKNOTS(I),',')
          call SERV1('TKNOTS(I+KORDER)',TKNOTS(I+KORDER),'.')
          go to 200
        END IF
   20 continue
C
C     Require LDW .ge. NC+2
C
      IF (LDW .lt. NC+2) THEN
        IERR1 = 300
        call IERM1('SSFIT',IERR1,0,'Require LDW .ge. NC+2',
     *             'LDW',LDW,',')
        call IERV1('NC',NC,'.')
        go to 200
      END IF
C
c     ------------------------------------------------------------------
C                                       TEST SDI(1)
      IF(SDI(1) .lt. ZERO) THEN
         WT1 = -ONE/SDI(1)
         USEWT1 = .true.
      ELSEIF( SDI(1) .gt. ZERO) THEN
         USEWT1 = .false.
      ELSE
         IERR1 = 1100
         call ERMSG('SSFIT',IERR1,0,'Require SD(1) .ne. Zero','.')
         return
      END IF
C
c                             Test ordering of XI() array.
c
      if(XI(NXY) .ge. XI(1)) then
         DIRECT = .true.
      else
         DIRECT = .false.
         NXYP1 = NXY+1
      end if
      IERR1 = 0
      do 40 I=2,NXY
         if(DIRECT) then
            if (XI(I-1) .gt. XI(I)) then
               IERR1 = 400
               go to 50
            end if
         else
            if (XI(I-1) .lt. XI(I)) then
               IERR1 = 400
               go to 50
            end if
         end if
   40 continue
   50 continue
      if(IERR1 .ne. 0) then
         call IERM1('SSFIT',IERR1,0,
     *   'Require abcissas, X(), to be sorted.',
     *   'I',I,',')
         call IERV1('NXY',NXY,',')
         call SERV1('  X(1)',XI(1),',')
         call SERV1('X(I-1)',XI(I-1),',')
         call SERV1('  X(I)',XI(I),',')
         call SERV1('X(NXY)',XI(NXY),'.')
         go to 200
      end if
C
C     Begin loop to form equations for least-squares spline fit.
C
      IRNOW = 1
      K = 1
      KSIZE = 0
      ISEG = 1
      LEFT = ISEG + KORDER - 1
      do 80 JPT = 1, NXY
         if(DIRECT) then
            JPOINT = JPT
         else
            JPOINT = NXYP1-JPT
         end if
         IF( K .gt. LDW ) THEN
            call SBACC(W, LDW, NBAND, IRNOW, KSIZE, ISEG, JTPREV, IERR2)
            if(IERR2 .ne. 0) then
               IERR1 = 700 + IERR2
               go to 100
            end if

            IF(IRNOW .gt. LDW) then
               IERR1 = 600
               call IERM1('SSFIT',IERR1,0,'Require LDW .ge. NC+2',
     *             'LDW',LDW,',')
               call IERV1('NC',NC,'.')
               go to 200
            END IF
            K = IRNOW
            KSIZE = 0
         END IF
c
C        DO WHILE(XI(JPOINT) .ge. TKNOTS(LEFT+1) .and. ISEG .lt. ISGMAX)
   60    if (XI(JPOINT) .ge. TKNOTS(LEFT+1) .and. ISEG .lt. ISGMAX) then
            call SBACC(W, LDW, NBAND, IRNOW, KSIZE, ISEG, JTPREV, IERR2)
            if(IERR2 .ne. 0) then
               IERR1 = 800 + IERR2
               go to 100
            end if
            KSIZE = 0
            K = IRNOW
            ISEG = ISEG + 1
            LEFT = LEFT + 1
            go to 60
         end if
C        END WHILE
c
c                                 Build one equation
         call SSBASD(KORDER, LEFT, TKNOTS, XI(JPOINT), 0, P)
         IF( USEWT1) THEN
            WT = WT1
         ELSE
            sdijp = sdi(jpoint)
            if(sdijp .gt. ZERO) then
               WT=ONE/sdijp
            else
               IERR1 = 1200
               call ERMSG('SSFIT',IERR1,0,
     *            'With SD(1) > 0  require all SD(I) > 0.', ',')
               call SERV1('SD(1)',SDI(1),',')
               call IERV1('I',jpoint,',')
               call SERV1('SD(I)',sdijp,'.')
               return
            end if
         END IF
         do 70 J = 1,KORDER
            W(K,J)=P(J)*WT
   70    continue
         W(K,KORDP1)=YI(JPOINT)*WT
c                                 End of build one equation
         K = K+1
         KSIZE = KSIZE + 1
c
   80 continue
      call SBACC(W, LDW, NBAND, IRNOW, KSIZE, ISEG, JTPREV, IERR2)
            if(IERR2 .ne. 0) then
               IERR1 = 900 + IERR2
               go to 100
            end if
C
C     ALL DATA POINTS HAVE BEEN PROCESSED.  CALL FOR SOLUTION.
C
      call SBSOL(1,W, LDW, NBAND, IRNOW, JTPREV, BCOEF,
     *           NC, RNORM, IERR3)
            if(IERR3 .ne. 0) then
               IERR1 = 1000 + IERR2
               call ERMSG('SSFIT',IERR1,0,
     *         'Singularity noted in SBSOL.','.')
               go to 200
            end if

      DOF = MAX(1, NXY - NC)
      SIGFAC = RNORM / sqrt(DOF)
      RETURN
C
C                                 ERROR IN _BACC
  100 call ERMSG('SSFIT',IERR1,0,
     *   'Error detected in subroutine SBACC','.')
C
C                                 ERROR RETURN
  200 do 220 I=1,NC
         BCOEF(I)=ZERO
  220 continue
      RETURN
      END


	REAL FUNCTION TCUMFCN(T,DF)
	USE MSFLIB
C
C-Description-----------------------------------------------------------
	IMPLICIT NONE
C
C  Function:
C	Calculate the probability that a t statistic with DF degrees
C	of freedom is <= T.
C  Arguments:
C	T	(Real)
C		T STATISTIC
C	DF	(Integer)
C		DEGREES OF FREEDOM
C  Notes:
C    .	Reference:
C	"Student's t-Distribution", _Collected Algorithms
C	from CACM_, vol II, Algorithm 344, 1980.
C
C-Declarations----------------------------------------------------------
C
C
C  Arguments
C
        REAL T
        INTEGER DF
C
C  Functions
C
	DOUBLE PRECISION PHI
C
C  Locals
C
        REAL D2,F1,F2,T1,T2,TPVALUE
        INTEGER I,N,LOCDF
C
C  D1=2/PI
C
	REAL D1
        DATA D1/.63661977/
C
C-Code------------------------------------------------------------------
C
C    Copy DF to local DF variable so calling value will not get changed.
C
	LOCDF=DF

      IF(LOCDF .LT. 0) THEN
C
C    ERROR IF LOCDF NOT POSITIVE
C
C	    STOP 'LOCDF NOT POSITIVE in TCUMFCN'
c		I=RAISEQQ(SIG$ABORT)
		locdf=0
		tcumfcn=0
		return
	ELSE IF (LOCDF.EQ.0) THEN
	    LOCDF=1
	ELSE IF (LOCDF.GT.120) THEN
	    TCUMFCN=REAL(PHI(T))
	    RETURN
      ENDIF
        T1=ABS(T)/SQRT(REAL(LOCDF))
        T2=1./(1.+T1*T1)
        IF((LOCDF/2)*2.NE.LOCDF) THEN
C
C    LOCDF ODD
C
            TPVALUE=1.-D1*ATAN(T1)
            IF(LOCDF.GT.1)THEN
                D2=D1*T1*T2
                TPVALUE=TPVALUE-D2
                IF (LOCDF.GT.3) THEN
                    F1 =0.
                    N=(LOCDF-2)/2
                        DO 10 I=1,N
			    F2=2.*REAL(I)-F1
			    D2=D2*T2*F2/(F2+1.)
			    TPVALUE=TPVALUE-D2
10			CONTINUE
                ENDIF
            ENDIF
        ELSE
C
C    LOCDF IS EVEN
C
            D2 = T1*SQRT(T2)
            TPVALUE=1.-D2
            IF(LOCDF.GT. 2)THEN
                F1=1.
                N=(LOCDF-2)/2
                    DO 20 I=1,N
			F2=2.*REAL(I)-F1
			D2=D2*T2*F2/(F2+1.)
			TPVALUE=TPVALUE-D2
20		    CONTINUE
            ENDIF
        ENDIF
        IF(TPVALUE.LT.0.)THEN
	    TPVALUE=0.
	ELSE
	    TPVALUE=TPVALUE/2.
	END IF
	IF (T.LT.0) TPVALUE=1.-TPVALUE
	TCUMFCN=1.-TPVALUE

      RETURN
      END


    Program dgeqpf_example

!     DGEQPF Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: dtrsv
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dgeqp3, dormqr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0E0_dp
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: tol
      Integer :: i, ifail, info, k, lda, ldb, ldx, lwork, m, n, nrhs
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), b(:, :), tau(:), work(:), &
        x(:, :)
      Integer, Allocatable :: jpvt(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs
!     .. Executable Statements ..
      Write (nout, *) 'DGEQPF Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n, nrhs
      lda = m
      ldb = m
      ldx = m
      lwork = 64*n
      Allocate (a(lda,n), b(ldb,nrhs), tau(n), work(lwork), x(ldx,nrhs), &
        jpvt(n))

!     Read A and B from data file

      Read (nin, *)(a(i,1:n), i=1, m)
      Read (nin, *)(b(i,1:nrhs), i=1, m)

!     Initialize JPVT to be zero so that all columns are free

      jpvt(1:n) = 0

!     Compute the QR factorization of A

      Call dgeqp3(m, n, a, lda, jpvt, tau, work, lwork, info)

!     Choose TOL to reflect the relative accuracy of the input data

      tol = 0.01E0_dp

!     Determine which columns of R to use

loop: Do k = 1, n
        If (abs(a(k,k))<=tol*abs(a(1,1))) Then
          Exit loop
        End If
      End Do loop

!     Compute C = (Q**T)*B, storing the result in B

      k = k - 1

      Call dormqr('Left', 'Transpose', m, nrhs, n, a, lda, tau, b, ldb, work, &
        lwork, info)

!     Compute least squares solution by back-substitution in R*B = C
      Do i = 1, nrhs

        Call dtrsv('Upper', 'No transpose', 'Non-Unit', k, a, lda, b(1,i), 1)

!       Set the unused elements of the I-th solution vector to zero

        b(k+1:n, i) = zero

      End Do

!     Unscramble the least squares solution stored in B

      Do i = 1, n
        x(jpvt(i), 1:nrhs) = b(i, 1:nrhs)
      End Do

!     Print least squares solution

      Write (nout, *)
      Flush (nout)

!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_real_gen('General', ' ', n, nrhs, x, ldx, &
        'Least squares solution', ifail)

    End Program


module m_DoubleFactorial

implicit none

contains

real function DoubleFactorial( n_upper, n_lower )
! calculates ( 2 * n_upper + 1 ) !! / ( 2 * n_lower + 1 ) !! or just ( 2 * n_upper + 1 ) !!, if n_lower is not present

  integer           :: n_upper
  integer, optional :: n_lower
  integer           :: i, i_lower

  i_lower = 1
  if( present(n_lower) ) i_lower = n_lower + 1

  DoubleFactorial = 1.
  do i = i_lower, n_upper
    DoubleFactorial = DoubleFactorial * ( 2 * i + 1 )
  end do

end function DoubleFactorial

end module m_DoubleFactorial


module Matrix_op

  implicit none

  interface full_field
    module procedure full_field_vector, full_field_tensor
  end interface

  interface show
    module procedure show1i, show2i, show1d, show2d
  end interface

  interface kron
    module procedure kron2ri,kron2ir,kron2i,kron2r
  end interface

  interface ones
    module procedure ones1,ones2
  end interface

  interface inv
    module procedure invs,invm
  end interface

  interface horzcat
    module procedure h_1,h_2
  end interface

  interface vertcat
    module procedure v_1real,v_1int,v_2real,v_2int
  end interface

  interface mmat
    module procedure mmat1, mmat2
  end interface

  !interface incr
  !  module procedure incr1,incr2
  !end interface

  contains

  function cholesky(A) result(G)

    implicit none
    double precision, dimension(:,:) :: A
    integer :: n
    double precision, dimension(:,:), allocatable :: G  ! Displacement result.
    integer    :: i,j

    n = size(A,1)
    allocate(G(n,n))

    ! Light check of positive definite
    !do i = 1, n
    !   if (A(i,i).le.0.0d0) then
    !      b(:) = 0.0d0
    !      return
    !   end if
    !end do

    G(:,:)=0.0d0
    do j = 1, n
       G(j,j) = sqrt( A(j,j) - dot_product(G(j,1:j-1),G(j,1:j-1)) )
       do i = j+1, n
          G(i,j)  = ( A(i,j) - dot_product(G(i,1:j-1),G(j,1:j-1)) ) / G(j,j)
       end do
    end do

  end function cholesky

  subroutine inv_chol(G,b)

    implicit none
    !integer,    intent(in)    :: n
    double precision, dimension(:,:) :: G
    double precision, dimension(:) :: b

    !real*8,     intent(in)    :: A(n,n)
    !real*8,     intent(out)   :: G(n,n)
    !real*8, intent(inout) :: b(n)
    double precision :: tmp
    integer :: n,i,j

    ! G is the Cholesky decomposition of a given matrix.
    ! vector solution is saved in "b"

    n = size(G,1)

    ! [2]
    do i = 1, n
       tmp = 0.0d0
       do j = 1, i-1
          tmp = tmp + G(i,j)*b(j)
       end do
       b(i) = (b(i)-tmp)/G(i,i)
    end do

    ! [3]
    do i = n, 1, -1
       tmp = 0.0d0
       do j = i+1, n
          tmp = tmp + b(j)*G(j,i)
       end do
       b(i) = (b(i)-tmp)/G(i,i)
    end do

  end subroutine inv_chol

!!!!! full_field !!!!!

function full_field_vector(m1,m2) result(m)

  ! Function that calculate from the PGD to the full solution:
  !integer, dimension(:), allocatable :: siz, new_siz
  integer :: n,Nmode,Tngpt
  double precision, dimension(:,:) :: m1,m2
  double precision, dimension(:,:), allocatable :: m  ! Displacement result.

  n = size(m1,1)
  Nmode = size(m1,2)
  Tngpt = size(m2,1)

  allocate( m(n,Tngpt) )
  m = matmul( m1, transpose(m2)  )

end function full_field_vector

function full_field_tensor(m1,m2) result(m)

  ! Function that calculate from the PGD to the full solution:
  integer, dimension(:), allocatable :: siz, new_siz
  integer :: Nmode,Tngpt
  double precision, dimension(:,:,:,:) :: m1
  double precision, dimension(:,:) :: m2
  double precision, dimension(:,:), allocatable :: mi
  double precision, dimension(:,:,:,:), allocatable :: m  ! Displacement result.

  Nmode = size(m2,2)
  Tngpt = size(m2,1)

  allocate( siz(4) )
  allocate( new_siz(4) )

  siz = shape(m1)
  new_siz = siz; new_siz(4) = Tngpt

  allocate(  m(new_siz(1), new_siz(2), new_siz(3), new_siz(4))  )
  allocate( mi(size(m1)/Nmode,Tngpt) )

  mi = matmul( reshape(m1,  (/size(m1)/Nmode, Nmode/) ), transpose(m2) )
  m  = reshape( mi , (/new_siz(1), new_siz(2), new_siz(3), new_siz(4)/) )

end function full_field_tensor

!!!!! repmat 2D: !!!!!

function repmat(m,vecdim) result(r)

  implicit none
  double precision, dimension(:,:) :: m
  double precision, dimension(:,:), allocatable :: r
  integer, dimension(2) :: vecdim, sizem , sizef
  integer :: i,jr,j,ir

  sizem = shape(m)

  do i = 1,2 !(int i=0;i<siz.length;i++){
      sizef(i) = sizem(i)*vecdim(i)   ! sizf[i] = siz[i]*repdim[i];
  end do ! determine the final size desired after repmat. !} // determine the final size desired after repmat.

  allocate(r(sizef(1),sizef(2)))

  do jr = 1, vecdim(2) !for (int jr = 1; jr <= repdim[1]; jr++) {
    do j = 1, sizem(2) ! for (int j = 0; j < siz[1]; j++) {
      do ir = 1, vecdim(1) !for (int ir = 1; ir <= repdim[0]; ir++) {
        do i = 1,sizem(1)   ! for (int i = 0; i < siz[0]; i++) {
          r( (ir-1)*sizem(1)+i,(jr-1)*sizem(2)+j ) = m(i,j) ! result[ (ir-1)*siz[0]+i ][ (jr-1)*siz[1]+j ] = m[i][j];
        end do !} // 1st dim
      end do !} // 1st rep
    end do  !} // 2nd dim
  end do !} // 2nd rep

end function repmat

!public double[][] repmat(double m[][],int[] repdim){
!
!    int[] siz = size(m);
!    int[] sizf = new int[siz.length];
!    for (int i=0;i<siz.length;i++){
!        sizf[i] = siz[i]*repdim[i];
!    } // determine the final size desired after repmat.
!
!    double result[][] = new double[sizf[0]][sizf[1]];
!
!
!    for (int jr = 1; jr <= repdim[1]; jr++) {
!        for (int j = 0; j < siz[1]; j++) {
!            for (int ir = 1; ir <= repdim[0]; ir++) {
!                for (int i = 0; i < siz[0]; i++) {
!                    result[ (ir-1)*siz[0]+i ][ (jr-1)*siz[1]+j ] = m[i][j];
!                } // 1st dim
!            } // 1st rep
!        } // 2nd dim
!    } // 2nd rep

!    return result;
!} // end repmat 2D

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

function kron2ri(m1,m2) result(m)
  implicit none

  double precision, dimension(:,:) :: m1 ! input
  integer, dimension(:,:) :: m2 ! input

  integer :: d1
  integer :: d2
  integer :: row1, column1, row2, column2
  integer :: i,j,k,l
  integer, allocatable, dimension(:) :: ind1, ind2 ! index that change over the iterations.
  double precision, allocatable, dimension(:,:) :: m ! output

  row1 = size(m1,1);  column1 = size(m1,2)
  row2 = size(m2,1);  column2 = size(m2,2)

  d1 = size(m1,1)*size(m2,1)
  d2 = size(m1,2)*size(m2,2)

  allocate( m(d1,d2) )

  ind1 = incr(1,size(m2,1)); ind2 = incr(1,size(m2,2))

  !call show(ind1)  ! shows the vector

  do i = 1,row1
    do j = 1,column1
      do k = 1,row2
        do l = 1,column2
          m((i-1)*row2+k,(j-1)*column2+l) =  m1(i,j)*m2(k,l)
        end do
      end do
    end do
  end do

end function kron2ri

  function kron2ir(m1,m2) result(m)
    implicit none

    integer, dimension(:,:) :: m1 ! input
    double precision, dimension(:,:) :: m2 ! input

    integer :: d1
    integer :: d2
    integer :: row1, column1, row2, column2
    integer :: i,j,k,l
    integer, allocatable, dimension(:) :: ind1, ind2 ! index that change over the iterations.
    double precision, allocatable, dimension(:,:) :: m ! output

    row1 = size(m1,1);  column1 = size(m1,2)
    row2 = size(m2,1);  column2 = size(m2,2)

    d1 = size(m1,1)*size(m2,1)
    d2 = size(m1,2)*size(m2,2)

    allocate( m(d1,d2) )

    ind1 = incr(1,size(m2,1)); ind2 = incr(1,size(m2,2))

    !call show(ind1)  ! shows the vector

    do i = 1,row1
      do j = 1,column1
        do k = 1,row2
          do l = 1,column2
            m((i-1)*row2+k,(j-1)*column2+l) =  m1(i,j)*m2(k,l)
          end do
        end do
      end do
    end do

  end function kron2ir

  function kron2i(m1,m2) result(m)
    implicit none

    integer, dimension(:,:) :: m1,m2 ! input
    integer :: d1
    integer :: d2
    integer :: row1, column1, row2, column2
    integer :: i,j,k,l
    integer, allocatable, dimension(:) :: ind1, ind2 ! index that change over the iterations.
    double precision, allocatable, dimension(:,:) :: m ! output

    row1 = size(m1,1);  column1 = size(m1,2)
    row2 = size(m2,1);  column2 = size(m2,2)

    d1 = size(m1,1)*size(m2,1)
    d2 = size(m1,2)*size(m2,2)

    allocate( m(d1,d2) )

    ind1 = incr(1,size(m2,1)); ind2 = incr(1,size(m2,2))

    !call show(ind1)  ! shows the vector

    do i = 1,row1
      do j = 1,column1
        do k = 1,row2
          do l = 1,column2
            m((i-1)*row2+k,(j-1)*column2+l) =  m1(i,j)*m2(k,l)
          end do
        end do
      end do
    end do

  end function kron2i

function kron2r(m1,m2) result(m)
  implicit none

  double precision, dimension(:,:) :: m1,m2 ! input
  integer :: d1
  integer :: d2
  integer :: row1, column1, row2, column2
  integer :: i,j,k,l
  integer, allocatable, dimension(:) :: ind1, ind2 ! index that change over the iterations.
  double precision, allocatable, dimension(:,:) :: m ! output

  row1 = size(m1,1);  column1 = size(m1,2)
  row2 = size(m2,1);  column2 = size(m2,2)

  d1 = size(m1,1)*size(m2,1)
  d2 = size(m1,2)*size(m2,2)

  allocate( m(d1,d2) )

  ind1 = incr(1,size(m2,1)); ind2 = incr(1,size(m2,2))

  !call show(ind1)  ! shows the vector

  do i = 1,row1
    do j = 1,column1
      do k = 1,row2
        do l = 1,column2
          m((i-1)*row2+k,(j-1)*column2+l) =  m1(i,j)*m2(k,l)
        end do
      end do
    end do
  end do

end function kron2r

!!!!!!!!!!!!!!!!!!

function ones1(s1) result(v)
  implicit none
  integer :: s1
  integer, dimension(s1) :: v ! output
  v = 1
end function ones1

function ones2(s1,s2) result(v)
  implicit none
  integer :: s1,s2
  integer, dimension(s1,s2) :: v ! output
  v = 1
end function ones2

! mmat:

  function mmat1(m1,m2) result(m)
    implicit none

    double precision, dimension(:,:,:) :: m1,m2 ! input
    integer :: d3
    integer :: i
    double precision, dimension(size(m1,1),size(m2,2),size(m1,3)) :: m ! output
    !double precision :: aux,auxp

    d3 = size(m1,3) ! third dimension of the matrices (assume same d3 for both)

    do i = 1,d3
        m(:,:,i) = matmul(m1(:,:,i),m2(:,:,i))
    end do

  end function mmat1

  function mmat2(m1,m2) result(m)
    implicit none

    double precision, dimension(:,:) :: m1 ! input
    double precision, dimension(:,:,:) :: m2 ! input
    integer :: d3
    integer :: i
    double precision, dimension(size(m1,1),size(m2,2),size(m2,3)) :: m ! output
    !double precision :: aux,auxp

    d3 = size(m2,3) ! third dimension of the matrices (assume same d3 for both)

    do i = 1,d3
        m(:,:,i) = matmul(m1,m2(:,:,i))
    end do

  end function mmat2

! sort:

recursive subroutine sort(array)
    double precision, intent(inout)::array(:)
    double precision :: temp,pivot
    integer :: i,j,last,left,right

    last=size(array)

    if (last.lt.50) then ! use insertion sort on small arrays
       do i=2,last
          temp=array(i)
          do j=i-1,1,-1
             if (array(j).le.temp) exit
             array(j+1)=array(j)
          enddo
          array(j+1)=temp
       enddo
       return
    endif
    ! find median of three pivot
    ! and place sentinels at first and last elements
    temp=array(last/2)
    array(last/2)=array(2)
    if (temp.gt.array(last)) then
       array(2)=array(last)
       array(last)=temp
    else
       array(2)=temp
    endif
    if (array(1).gt.array(last)) then
       temp=array(1)
       array(1)=array(last)
       array(last)=temp
    endif
    if (array(1).gt.array(2)) then
       temp=array(1)
       array(1)=array(2)
       array(2)=temp
    endif
    pivot=array(2)

    left=3
    right=last-1
    do
       do while(array(left).lt.pivot)
          left=left+1
       enddo
       do while(array(right).gt.pivot)
          right=right-1
       enddo
       if (left.ge.right) exit
       temp=array(left)
       array(left)=array(right)
       array(right)=temp
       left=left+1
       right=right-1
    enddo
    if (left.eq.right) left=left+1
    call sort(array(1:left-1))
    call sort(array(left:))

  end subroutine sort

! inv matrix:

  function  invs(ms) result(minv)
    implicit none
    double precision ::  ms ! input
    double precision ::  minv ! output

    minv = 1/ms
  end function invs

  function  invm(ms) result(minv)
    implicit none
    ! double == double precision (arreglar esto, aumentar precision!)
    !real, intent(in), dimension(:,:) :: m ! input
    double precision, dimension(:,:) :: ms ! input
    integer :: d1,d2,i,i1,j
    double precision, dimension(size(ms,1),size(ms,2)) :: minv,m ! output
    double precision :: aux,auxp

    d1 = size(ms,1);d2 = size(ms,2)
    m = ms

    ! Creation of the identity matrix:
    minv = 0
    do i=1,d1
      minv(i,i) = 1
    end do

    ! Calculation of the Inverse matrix:

    do i=1,d1
      aux = m(i,i)
      do j=1,d2
        m(i,j) = m(i,j)/aux
        minv(i,j) = minv(i,j)/aux
      end do ! j

      do i1 = 1,d1
        if (i1 /= i) then ! i1 not equal to i
          auxp = -m(i1,i);

          do j=1,d2
            m(i1,j) = m(i1,j) + m(i,j)*auxp;
            minv(i1,j) = minv(i1,j) + minv(i,j)*auxp;
          end do

        end if
      end do ! i1

    end do ! i

  end function invm

  function  linspace(vi,vf,N) result(m)
    implicit none
    double precision :: vi,vf,dx
    integer :: N,i
    double precision, dimension(N) :: m ! output

    dx = (vf-vi)/(N-1)
    m = (/(i, i=0,N-1, 1)/)*dx

  end function linspace

  ! integer array formed: (equivalent matlab a:b)

  function  incr(a,b) result(m)
    implicit none
    integer :: a,b,i,N
    integer, allocatable, dimension(:) :: m ! output

    N = b-a+1
    allocate( m(N) )  != (/(i, i=a, b, 1)/)
    m = (/(i, i=a, b, 1)/)

  end function incr

  function  incr2(a,b) result(m)
    implicit none
    integer :: a,b,i,N
    integer, allocatable, dimension(:,:) :: m ! output

    N = b-a+1
    allocate( m(1,N) )  != (/(i, i=a, b, 1)/)
    m(1,:) = (/(i, i=a, b, 1)/)
    !DEALLOCATE(m)
  end function incr2

! horzcat:

function h_1(m1,m2) result(m)
  implicit none
  double precision, dimension(:) :: m1,m2 ! input
  double precision, dimension(size(m1)+size(m2)) :: m ! output

  m = [m1,m2]
  !m(1:size(m1,1)) = m1
  !m(size(m1,1)+1:(size(m1,1)+size(m2,1))) = m2

end function h_1

function h_2(m1,m2) result(m)
  implicit none
  double precision, dimension(:,:) :: m1,m2 ! input
  double precision, dimension(size(m1,1),size(m1,2)+size(m2,2)) :: m ! output

  m(:,1:size(m1,2)) = m1
  m(:,size(m1,2)+1:size(m1,2)+size(m2,2)) = m2

end function h_2

! vertcat:

function v_1real(m1,m2) result(m)
  implicit none
  double precision, dimension(:) :: m1,m2 ! input
  double precision, dimension(2,size(m1)) :: m ! output

  m(1,:) = m1
  m(2,:) = m2

end function v_1real

function v_1int(m1,m2) result(m)
  implicit none
  integer, dimension(:) :: m1,m2 ! input
  integer, dimension(2,size(m1)) :: m ! output

  m(1,:) = m1
  m(2,:) = m2

end function v_1int

function v_2real(m1,m2) result(m)
  implicit none
  double precision, dimension(:,:) :: m1,m2 ! input
  double precision, dimension(size(m1,1)+size(m2,1),size(m1,2)) :: m ! output

  m(1:size(m1,1),:) = m1
  m(size(m1,1)+1:size(m1,1)+size(m2,1),:) = m2

end function v_2real

function v_2int(m1,m2) result(m)
  implicit none
  integer, dimension(:,:) :: m1,m2 ! input
  integer, dimension(size(m1,1)+size(m2,1),size(m1,2)) :: m ! output

  m(1:size(m1,1),:) = m1
  m(size(m1,1)+1:size(m1,1)+size(m2,1),:) = m2

end function v_2int

!!!!!!!!

subroutine show1i(m)
  implicit none
  integer, dimension(:) :: m ! input
  integer :: row

  do row = 1,size(m)
    print*, m(row)
  end do

end subroutine show1i

subroutine show2i(m)
  implicit none
  integer, dimension(:,:) :: m ! input
  integer :: row

  do row = 1,size(m,1)
    print*, m(row,:)
  end do

end subroutine show2i

subroutine show1d(m)
  implicit none
  double precision, dimension(:) :: m ! input
  integer :: row

  do row = 1,size(m)
    print*, m(row)
  end do

end subroutine show1d

subroutine show2d(m)
  implicit none
  double precision, dimension(:,:) :: m ! input
  integer :: row

  do row = 1,size(m,1)
    print*, m(row,:)
  end do

end subroutine show2d

end module Matrix_op


!! CALCULO NUMERICO DE LAS DERIVADAS DE LOS CAMPOS !!

subroutine numeric

    use arrays
    use global

    implicit none

    integer i          !variable de iteracion
    real(kind = 8) idx !aux

    !calculo numerico por diferencias finitas (derivadas de 2 orden)
    idx = 1.0d0/dx !mas eficiente en cada iteracion
    !derivadas centradas
    do i = 1, Nx-1
        dPsi(i) = 0.5d0*(Psi(i+1) - Psi(i-1))*idx
        dPi(i)  = 0.5d0*(Pi(i+1) - Pi(i-1))*idx
    end do
    !derivadas laterales
    dPsi(0)  = 0.5d0*(-3.0d0*Psi(0) + 4.0d0*Psi(1) - Psi(2))*idx
    dPsi(Nx) = 0.5d0*(3.0d0*Psi(Nx) - 4.0d0*Psi(Nx-1) + Psi(Nx-2))*idx
    dPi(0)   = 0.5d0*(-3.0d0*Pi(0)  + 4.0d0*Pi(1)  - Pi(2))*idx
    dPi(Nx)  = 0.5d0*(3.0d0*Pi(Nx)  - 4.0d0*Pi(Nx-1)  + Pi(Nx-2))*idx

    !valores numericos segun la metrica
    if (Metric.eq.0) then       !Mink
        numeric_Phi = Pi
        numeric_Psi = dPi
        numeric_Pi  = dPsi
    else if (Metric.eq.1) then  !Schwar
        numeric_Phi = alpha*Pi + beta*Psi
        numeric_Psi = alpha*dPi + dalpha*Pi + beta*dPsi + dbeta*Psi
        numeric_Pi  = dgamma*(beta*Pi + alpha*gamma_rr*Psi)/gamma &
        + beta*dPi + dbeta*Pi + dalpha*gamma_rr*dPsi &
        + alpha*dgamma_rr*Psi + alpha*gamma_rr*dPsi
    else
        print *, 'METRIC NO IMPLEMENTED YET'
    end if

end subroutine numeric


Program P2
	Implicit none
	real*8 :: dt, min, max, t
	real*8, dimension(2) :: y
	integer :: n
	parameter (n=2) ! y 1: pos; 2: vel;

	! inteval
	min=0.0D0
	max=200.0D0
	! time step
	dt=0.1D0
	! initial position
	y(1)=0.0D0
	! initial velocity
	y(2)=4.0D0

	Open(6, File='P2.dat')
	! Runga-Kutta iteration
	Do t=min, max, dt
		Call rk2(t, dt, y, n)
		Write (6,*) t, y(2) ! y(2): vel
	enddo

	Close(6)
End program P2

! second-order Runge-Kutta subroutine
! will update y(1) & y(2) based on n
subroutine rk2(t, dt, y, n)
	Implicit none
	real*8, external :: deriv
	real*8, intent(in) :: t, dt
	real*8, intent(inout), dimension(2) :: y
	real*8 :: h
	real*8, dimension(2) :: k1, k2, t1
	integer :: i,n

	h=dt/2.0D0
	Do i = 1,n
	   k1(i) = dt * deriv(y, i)
	   t1(i) = y(i) + 0.5D0*k1(i)
	enddo
	Do i = 1,n
	   k2(i) = dt * deriv(t1, i)
	   y(i) = y(i) + k2(i)
	enddo
	Return
End subroutine rk2

! function which returns the derivatives (RHS)
real*8 function deriv(temp, i)
	Implicit none
! declarations
	Real*8 :: omega, alpha
	real*8, dimension(2), intent(inout):: temp
	Integer :: i
	data omega /5.7143d0/
	data alpha /0.15d0/

	If (i .EQ. 1) deriv=temp(2)
	If (i .EQ. 2) deriv=omega / temp(2) - alpha* temp(2)**2
	Return
End function deriv


Program testit
  !!----------------------------------------------------
  !! Program to test the execution of the finite difference
  !! library by calculating the charge from a screened
  !! Gaussian according to
  !! $$ \rho _i^s(\mathbf r)=-q_i\left(\frac{\alpha }{\sqrt{\pi }}\right)^3e^{-\alpha^2 |\mathbf r-\mathbf r_i|^2} $$
  !!
  !! Written by I.J. Bush
  !!----------------------------------------------------

  Use numbers_module        , Only : wp
  Use FD_Laplacian_3d_module, Only : FD_Laplacian_3D

  Implicit None

  Type( FD_Laplacian_3d ) :: FD

  Real( wp ), Dimension( :, :, : ), Allocatable :: grid
  Real( wp ), Dimension( :, :, : ), Allocatable :: laplacian
  Real( wp ), Dimension( :, :, : ), Allocatable :: fd_laplacian

  Real( wp ), Dimension( 1:3, 1:3 ) :: grid_vecs

  Real( wp ), Dimension( 1:3 ) :: r, ri

  Real( wp ) :: alpha, alpha_sq
  Real( wp ) :: x, y, z
  Real( wp ) :: norm
  Real( wp ) :: arg
  Real( wp ) :: gauss, gauss_x2, gauss_y2, gauss_z2
  Real( wp ) :: max_error, rel_error, rel_value, max_rel_error

  Integer, Dimension( 1:3 ) :: grid_size, grid_with_halo

  Integer :: order
  Integer :: i3, i2, i1
  Integer :: start, finish, rate

  Write( *, * ) 'Grid vecs?'
  Read ( *, * ) grid_vecs

  Write( *, * ) 'ri ?'
  Read ( *, * ) ri

  Write( *, * ) 'alpha ?'
  Read ( *, * ) alpha
  alpha_sq = alpha * alpha

  Write( *, * ) 'order ?'
  Read ( *, * ) order

  Write( *, * ) 'grid_size ?'
  Read ( *, * ) grid_size

  grid_with_halo = grid_size + order / 2

  Allocate( grid( &
    & -grid_with_halo( 1 ):grid_with_halo( 1 ), &
    & -grid_with_halo( 2 ):grid_with_halo( 2 ), &
    & -grid_with_halo( 3 ):grid_with_halo( 3 ) ) )
  Allocate( laplacian( &
    & -grid_with_halo( 1 ):grid_with_halo( 1 ), &
    & -grid_with_halo( 2 ):grid_with_halo( 2 ), &
    & -grid_with_halo( 3 ):grid_with_halo( 3 ) ) )
  Allocate( fd_laplacian( &
    & -grid_size( 1 ):grid_size( 1 ), &
    & -grid_size( 2 ):grid_size( 2 ), &
    & -grid_size( 3 ):grid_size( 3 ) ) )

  Call system_clock( start, rate )
  norm = ( alpha / Sqrt( 3.1415926535897932384626433832795_wp ) ) ** 3
  Do i3 = -grid_with_halo( 3 ), grid_with_halo( 3 )
    Do i2 = -grid_with_halo( 2 ), grid_with_halo( 2 )
      Do i1 = -grid_with_halo( 1 ), grid_with_halo( 1 )
        r = i1 * grid_vecs( :, 1 ) + i2 * grid_vecs( :, 2 ) + i3 * grid_vecs( :, 3 ) - ri
        arg = alpha_sq * Dot_Product( r, r )
        gauss = norm * Exp( - arg )
        grid( i1, i2, i3 ) = gauss
        x = r( 1 )
        y = r( 2 )
        z = r( 3 )
        gauss_x2 = gauss * ( - 2.0_wp * alpha_sq + 4.0 * alpha_sq * alpha_sq * x * x )
        gauss_y2 = gauss * ( - 2.0_wp * alpha_sq + 4.0 * alpha_sq * alpha_sq * y * y )
        gauss_z2 = gauss * ( - 2.0_wp * alpha_sq + 4.0 * alpha_sq * alpha_sq * z * z )
        laplacian( i1, i2, i3 ) = gauss_x2 + gauss_y2 + gauss_z2
      End Do
    End Do
  End Do
  Call system_clock( finish, rate )
  Write( *, '( a, t30, f8.3 )' ) 'Time for griding charge', Real( finish - start ) / rate

  Call FD%init( order, grid_vecs )
  Call system_clock( start, rate )
  Call FD%apply( -grid_with_halo, -grid_size, -grid_size, grid_size, grid, fd_laplacian )
  Call system_clock( finish, rate )
  Write( *, '( a, t30, f8.3 )' ) 'Time for FD laplacian', Real( finish - start ) / rate

  max_error =  Maxval( Abs( fd_laplacian - &
    laplacian( &
    & -grid_size( 1 ):grid_size( 1 ), &
    & -grid_size( 2 ):grid_size( 2 ), &
    & -grid_size( 3 ):grid_size( 3 ) ) ) )
  Write( *, '( a, t40, ": ", g22.16 )' ) 'Maximum error in laplacian', max_error
  max_rel_error = -1.0_wp
  rel_error = max_rel_error
  Do i3 = - grid_size( 3 ), grid_size( 3 )
     Do i2 = - grid_size( 2 ), grid_size( 2 )
        Do i1 = - grid_size( 1 ), grid_size( 1 )
           If( Abs( laplacian( i3, i2, i1 ) ) > 1.0e-12_wp ) Then
              rel_error = Abs( fd_laplacian( i1, i2, i3 ) - laplacian( i1, i2, i3 ) )
              rel_error = rel_error / Abs( laplacian( i1, i2, i3 ) )
              If( rel_error > max_rel_error ) Then
                 max_rel_error = rel_error
                 rel_value = laplacian( i1, i2, i3 )
              End If
           End If
        End Do
     End Do
  End Do
  Write( *, '( a, t40, ": ", g22.16, a, g22.16 )' ) &
       'Maximum relative error in laplacian', max_rel_error, ' where laplacian = ', rel_value
  Write( *, '( a, t40, ": ", g22.16 )' ) 'Maximum value of laplacian ', &
       Maxval( Abs( laplacian( &
    & -grid_size( 1 ):grid_size( 1 ), &
    & -grid_size( 2 ):grid_size( 2 ), &
    & -grid_size( 3 ):grid_size( 3 ) ) ) )

End Program testit


module powermodule

  integer, parameter :: nd=10, np=3
  real(8) :: xpowers(np,nd)

contains

  subroutine initpowers(dx)

  implicit none

  integer :: i,j
  real(8) :: dx

  do i=1,nd
     xpowers(1,i)=dx*i
  enddo
  do i=2,np
     xpowers(i,:)=xpowers(1,:)**i
  enddo

  end subroutine initpowers

end module powermodule

 use powermodule

 implicit none

 integer :: i
 real(8) :: a(0:np),px,dx

 print*,'Give x-spacing '; read*,dx
 do i=0,np
   print*,'Give polynomial coefficient ',i; read*,a(i)
 enddo
 call initpowers(dx)
 do i=1,nd
   px=a(0)+dot_product(xpowers(1:np,i),a(1:np))
   print*,xpowers(1,i),px
 enddo

 end


module random_normal_mod
implicit none
contains
impure elemental subroutine random_normal(ran_norm)
! adapted from https://jblevins.org/mirror/amiller/ran_norm.f90
real, intent(out) :: ran_norm ! normal variate
real, parameter :: s = 0.449871, t = -0.386595, a = 0.19600, &
      b = 0.25472, half = 0.5, r1 = 0.27597, r2 = 0.27846
real :: u, v, x, y, q
do
  call random_number(u)
  call random_number(v)
  v = 1.7156 * (v - half)
  x = u - s
  y = abs(v) - t
  q = x**2 + y*(a*y - b*x)
  if (q < r1) exit
  if (q > r2) cycle
  if (v**2 < -4.0*log(u)*u**2) exit
end do
ran_norm = v/u
end subroutine random_normal
end module random_normal_mod
!
program test_random_normal
use random_normal_mod
implicit none
integer, parameter :: n = 10**6, ncol = 3
integer :: i, k
real :: x(n,ncol)
character (len=*), parameter :: fmt = "(a8,*(1x,f6.3))"
call random_seed()
call random_normal(x)
print "(a8,*(1x,i6))", "power",(k,k=1,4)
print fmt, "true",real([0,1,0,3])
do i=1,ncol
   print fmt, "sim",(sum(x(:,i)**k)/n,k=1,4)
end do
end program test_random_normal
! sample output:
!    power      1      2      3      4
!   moment -0.001  0.999 -0.002  2.991
!   moment  0.001  1.000  0.003  2.995
!   moment -0.000  0.999 -0.002  2.997