module roots

  use, intrinsic :: iso_fortran_env, only: wp => real64
  implicit none

  logical, private, parameter :: debug = .true.

  abstract interface
     real(wp) function func(x)
       import :: wp
       implicit none
       real(wp), intent(in) :: x
     end function func
  end interface

contains

  subroutine biseccion ( f, a, b, n, tol, raiz, clave )

    ! METODO DE BISECCION para encontrar una solución
    ! de f(x)=0 dada la función continua f en el intervalo
    ! [a,b] donde f(a) y f(b) tienen signos opuestos.

    ! Argumentos
    procedure(func)          :: f     ! Función que define la ecuación
    real(wp), intent(in)     :: a     ! Extremo izquierdo del intervalo inicial
    real(wp), intent(in)     :: b     ! Extremo derecho del intervalo inicial
    integer,  intent(in out) :: n     ! Límite de iteraciones/iteraciones realizadas
    real(wp), intent(in)     :: tol   ! Tolerancia para el error absoluto
    real(wp), intent(out)    :: raiz  ! Aproximación a la raiz
    integer,  intent(out)    :: clave ! Clave de éxito:
                                      !   0 : éxito
                                      !  >0 : iteraciones excedidas
                                      !  <0 : no se puede proceder (f de
                                      !       igual signo en a y b)
    ! Variables locales
    integer  :: i
    real(wp) :: xl, xr, error

    clave = 1
    xl    = a
    xr    = b
    if ( sign( 1.0_wp , f(xl) ) * sign ( 1.0_wp, f(xr) ) > 0.0_wp ) then
       clave = -1
       return
    endif

    if ( debug ) write(*,'(a)') '    i          x_i'

    do i=1,n

       error = (xr-xl)*0.5_wp
       raiz  = xl + error

       if ( debug ) write(*,'(i5,2x,g0)') i, raiz

       if ( error <= tol ) then
          clave = 0
          n     = i
          exit
       endif

       if ( sign( 1.0_wp, f(xl) ) * sign( 1.0_wp, f(raiz) ) > 0.0_wp ) then
          xl = raiz
       else
          xr = raiz
       endif

    enddo

  end subroutine biseccion

  subroutine newton ( f, df, x0, n, tol, raiz, clave )

    ! Metodo DE NEWTON-RAPHSON para encontrar una
    ! solución de f(x)=0 dada la función derivable
    ! f y una aproximación inicial x0.

    ! Argumentos
    procedure(func)          :: f     ! Función que define la ecuación
    procedure(func)          :: df    ! Derivada de la función que define la ecuación
    real(wp), intent(in)     :: x0    ! Aproximación inicial a la raíz
    integer,  intent(in out) :: n     ! Límite de iteraciones/iteraciones realizadas
    real(wp), intent(in)     :: tol   ! Tolerancia para el error relativo
    real(wp), intent(out)    :: raiz  ! Aproximación a la raiz
    integer,  intent(out)    :: clave ! Clave de éxito:
                                      !   0 : éxito
                                      !  >0 : iteraciones excedidas
    ! Variables locales
    integer  ::  i
    real(wp) :: xx0

    clave = 1
    xx0   = x0

    if ( debug ) write(*,'(a)') '    i          x_i'

    do i=1,n
       raiz  = xx0 - f(xx0)/df(xx0)

       if ( debug ) write(*,'(i5,2x, g0)') i, raiz

       if ( abs( raiz-xx0 ) <= tol * abs( raiz ) ) then
          clave = 0
          n     = i
          exit
       endif

       xx0 = raiz

    end do

  end subroutine newton

  subroutine secante ( f, x0, x1, n, tol, raiz, clave )

    ! ALGORITMO DE LA SECANTE para encontrar una solución
    ! de f(x)=0, siendo f una función continua, dada las
    ! aproximaciones iniciales x0 y x1.

    ! Argumentos
    procedure(func)          :: f     ! Función que define la ecuación
    real(wp), intent(in)     :: x0,x1 ! Aproximaciones iniciales a la raíz
    integer,  intent(in out) :: n     ! Límite de iteraciones/iteraciones realizadas
    real(wp), intent(in)     :: tol   ! Tolerancia para el error relativo
    real(wp), intent(out)    :: raiz  ! Aproximación a la raiz
    integer,  intent(out)    :: clave ! Clave de éxito:
                                      !   0 : éxito
                                      !  >0 : iteraciones excedidas

    ! Variables locales
    integer :: i
    real(wp):: xx0, xx1, fx0, fx1

    clave = 1
    xx0   = x0
    xx1   = x1
    fx0   = f(x0)
    fx1   = f(x1)

    if ( debug ) write(*,'(a)') '    i          x_i'

    do i= 1,n

       raiz  = xx1 - fx1 * ( ( xx1-xx0 ) / ( fx1-fx0 ) )

       if ( debug ) write(*,'(i5,2x, g0)') i, raiz

       if ( abs( raiz-xx1 ) <= tol * abs( raiz ) ) then
          clave = 0
          n     = i
          exit
       endif

       xx0 = xx1
       fx0 = fx1
       xx1 = raiz
       fx1 = f(raiz)

    end do

  end subroutine secante

  subroutine birge_vieta ( a, x0, n, tol, raiz, clave )

    ! METODO DE BIRGE-VIETA para resolver ECUACIONES ALGEBRAICAS:
    ! P(x) = 0 donde P es un polinomio de grado m de coeficientes reales.
    ! El método se basa en el método de Newton-Raphson implementando el
    ! esquema de Horner para la evaluación del polinomio y su derivada.

    ! Argumentos
    real(wp), intent(in)     :: a(0:)  ! Vector de m+1 elementos conteniendo
                                       ! los coeficientes del polinomio
    real(wp), intent(in)     :: x0     ! Aproximación inicial a la raíz
    real(wp), intent(in)     :: tol    ! Tolerancia para el error relativo
    integer,  intent(in out) :: n      ! Límite de iteraciones/iteraciones realizadas
    real(wp), intent(out)    :: raiz   ! Aproximación a la raiz
    integer,  intent(out)    :: clave  ! Clave de éxito:
                                       !   0 : éxito
                                       !  >0 : iteraciones excedidas
    ! Variables locales
    integer :: m, i, j
    real(wp):: xx0,b,c

    clave = 1
    xx0   = x0
    m     = size(a)-1

    if ( debug ) write(*,'(a)') '    i          x_i'

    do i=1,n

       ! Esquema de Horner
       b = a(m)
       c = a(m)
       do j=m-1,1,-1
          b = b*xx0+a(j)
          c = c*xx0+b
       enddo
       b = b*xx0+a(0)

       ! Método de Newton
       raiz  = xx0 - b/c

       if ( debug ) write(*,'(i5,2x,g0)') i, raiz

       if ( abs( raiz-xx0 ) <= tol * abs( raiz ) ) then
          clave = 0
          n     = i
          exit
       end if
       xx0 = raiz
    end do

  end subroutine birge_vieta

  subroutine punto_fijo ( f, x0, n, tol, raiz, clave )

    ! ALGORITMO DE PUNTO FIJO o DE APROXIMACIONES SUCESIVAS
    ! para encontrar una solución de x=f(x) dada una
    ! aproximación inicial x0.

    ! Argumentos
    procedure(func)          :: f     ! Función que define la ecuación
    real(wp), intent(in)     :: x0    ! Aproximación inicial a la raíz
    integer,  intent(in out) :: n     ! Límite de iteraciones/iteraciones realizadas
    real(wp), intent(in)     :: tol   ! Tolerancia para el error relativo
    real(wp), intent(out)    :: raiz  ! Aproximación a la raiz
    integer,  intent(out)    :: clave ! Clave de éxito:
                                      !   0 : éxito
                                      !  >0 : iteraciones excedidas

    ! Variables locales
    integer  :: i
    real(wp) :: xx0

    clave = 1
    xx0   = x0

    if ( debug ) write(*,'(a)') '    i          x_i'

    do i=1,n
       raiz  = f(xx0)

       if ( debug ) write(*,'(i5,2x,g0)') i, raiz

       if ( abs( raiz-xx0 ) <= tol * abs( raiz ) ) then
          clave = 0
          n     = i
          exit
       endif
       xx0 = raiz
    end do

  end subroutine punto_fijo

  subroutine fzero( f, b, c, re, ae, iflag )

    ! Search for a zero of a function F(X) in a given interval
    ! (B,C).  It is designed primarily for problems where F(B)
    ! and F(C) have opposite signs.
    !
    ! Original author:
    !
    !  Shampine, L. F., (SNLA)
    !  Watts, H. A., (SNLA)
    !
    ! Modified by
    !
    !  Pablo Santamaría
    !
    ! Description
    !
    !     FZERO searches for a root of the nonlinear equation F(X) = 0
    !     (when F(X) is a real function of a single real variable X),
    !     between the given values B and C until the width
    !     of the interval (B,C) has collapsed to within a tolerance
    !     specified by the stopping criterion,
    !
    !                    ABS(B-C) <= 2*MAX(RW*ABS(B),AE).
    !
    !     The method used is an efficient combination of bisection and the
    !     secant rule and is due to T. J. Dekker.
    !
    ! Arguments
    !
    !   f     :EXT   - Name of the function subprogram defining F(X).
    !                  This subprogram should have the form
    !                   REAL(WP) FUNCTION F(X)
    !                      USE iso_fortan_env, ONLY: WP => REAL64
    !                      IMPLICIT NONE
    !                      REAL(WP), INTENT(IN) :: X
    !                      F = ...
    !                   END FUNCTION F
    !                  An explicit interface should be provided
    !                  in the calling program.
    !
    !   b     :INOUT - One end of the interval (B,C).  The
    !                  value returned for B usually is the better
    !                  approximation to a zero of F.
    !
    !   c     :INOUT - The other end of the interval (B,C)
    !
    !
    !   re    :IN    - Relative error used for RW in the stopping criterion.
    !                  If the requested RE is less than machine precision,
    !                  then RW is set to approximately machine precision.
    !
    !   ae    :IN    - Absolute error used in the stopping criterion.  If
    !                  the given interval (B,C) contains the origin, then a
    !                  nonzero value should be chosen for AE.
    !
    !   iflag :OUT   - A status code.  User must check IFLAG after each
    !                  call.  Control returns to the user from FZERO in all
    !                  cases.
    !
    !                0  B is within the requested tolerance of a zero.
    !                   The interval (B,C) collapsed to the requested
    !                   tolerance, the function changes sign in (B,C), and
    !                   F(X) decreased in magnitude as (B,C) collapsed.
    !
    !                1  F(B) = 0.  However, the interval (B,C) may not have
    !                   collapsed to the requested tolerance.
    !
    !               -1  B may be near a singular point of F(X).
    !                   The interval (B,C) collapsed to the requested tol-
    !                   erance and the function changes sign in (B,C), but
    !                   F(X) increased in magnitude as (B,C) collapsed, i.e.
    !                     ABS(F(B out)) > MAX(ABS(F(B in)),ABS(F(C in)))
    !
    !               -2  No change in sign of F(X) was found although the
    !                   interval (B,C) collapsed to the requested tolerance.
    !                   The user must examine this case and decide whether
    !                   B is near a local minimum of F(X), or B is near a
    !                   zero of even multiplicity, or neither of these.
    !
    !               -3  Too many (> 500) function evaluations used.
    !
    ! References
    !
    !      L. F. Shampine and H. A. Watts, FZERO, a root-solving
    !             code, Report SC-TM-70-631, Sandia Laboratories,
    !             September 1970.
    !      T. J. Dekker, Finding a zero by means of successive
    !             linear interpolation, Constructive Aspects of the
    !             Fundamental Theorem of Algebra, edited by B. Dejon
    !             and P. Henrici, Wiley-Interscience, 1969.
    !
    ! Notes
    !
    ! This implementation is a Fortran 90 refactoring from the original
    ! dfzero.f subroutine:
    !
    ! * http://www.netlib.org/slatec/src/dfzero.f
    !
    ! with some changes from:
    !
    ! * ftp://ftp.wiley.com/public/college/math/sapcodes/f90code/saplib.f90
    !

    ! Arguments
    procedure(func)          :: f
    real(wp), intent(in out) :: b
    real(wp), intent(in out) :: c
    real(wp), intent(in)     :: re
    real(wp), intent(in)     :: ae
    integer,  intent(out)    :: iflag

    ! Local variables
    real(wp) :: a, acbs, acmb, cmb
    real(wp) :: fa, fb, fc, fx
    real(wp) :: p, q
    real(wp) :: aw, rw, tol
    integer  :: ic, kount, max_feval
    logical  :: force_bisect
    character(7) :: method

    ! Set error tolerances
    rw = max( re, epsilon(1.0_wp) )
    aw = max( ae, 0.0_wp )

    ! Initialize
    max_feval = 500
    ic = 0

    fb = f( b )
    fc = f( c )
    kount = 2

    a = c
    fa = fc
    acbs = abs( b-c )
    fx = max( abs(fb), abs(fc) )

    if ( debug ) then
       write(*,'(a,1x,a,11x,a,19x,a,17x,a,15x,a)') 'F-count', &
            & 'method', 'b', 'c', 'f(b)', 'f(c)'
       method = 'initial'
    end if

    ! Iteration loop
    do

       ! Perform interchange such abs(f(b)) < abs(f(c))
       if ( abs( fc ) < abs( fb ) ) then
          a  = b
          fa = fb
          b  = c
          fb = fc
          c  = a
          fc = fa
       end if

       if ( debug ) write(*,'(i5,*(2x,g0))') kount, method, b, c, fb, fc

       cmb  = 0.5_wp * (c-b)
       acmb = abs( cmb )
       tol  = max( rw*abs(b), aw ) ! or tol = rw*abs(b) + aw

       ! Test stopping criterion and function count
       ! Set iflag appropriately
       if ( acmb <= tol ) then
          if ( sign( 1.0_wp, fb ) * sign( 1.0_wp, fc ) > 0.0_wp ) then
             iflag = -2
          else if ( abs( fb ) > fx ) then
             iflag = -1
          else
             iflag = 0
          end if
          exit
       endif

       if ( abs( fb ) <= 0.0_wp ) then
          iflag = 1
          exit
       end if

       if ( kount >= max_feval ) then
          iflag = -3
          exit
       end if

       ! Calculate new iterate implicitly as b+p/q, where we arrange
       ! p >= 0.  The implicit form is used to prevent overflow.
       p = (b-a) * fb
       q = fa - fb

       if ( p < 0.0_wp ) then
          p = -p
          q = -q
       end if

       ! Update a and check for satisfactory reduction in the size of the
       ! bracketing interval every four increments.
       ! If not, force bisection.
       a  = b
       fa = fb
       ic = ic + 1
       force_bisect = .false.

       if ( ic >= 4 ) then

          if ( 8.0_wp * acmb >= acbs ) then
             force_bisect = .true.
          else
             ic   = 0
             acbs = acmb
          end if

       end if

       ! Get new iterate b
       if ( force_bisect ) then
          b = b + cmb         ! Use bisection (c+b)/2
          if (debug) method = 'bisect*'
       else if ( p <=  abs(q) * tol ) then ! If to small, increment by tolerance
          b = b + sign( tol, cmb )
          if ( debug ) method = 'minimal'
       else if ( p < cmb * q ) then ! Root ought to be between b and (c+b)/2
          b = b + p/q  ! Use secant rule
          if ( debug ) method = 'secant'
       else
          b = b + cmb  ! Use bisection (c+b)/2
          if ( debug ) method = 'bisect'
       end if

       ! Have completed computation for new iterate b.
       fb = f( b )
       kount = kount + 1

       ! Decide whether next step is interpolation or extrapolation.
       if ( sign( 1.0_wp, fb ) * sign( 1.0_wp, fc ) > 0.0_wp ) then
          c  = a
          fc = fa
       end if

    end do

  end subroutine fzero

end module roots


Program P11

 implicit none

 integer :: i, j, n

 integer , allocatable , dimension(:,:) :: a, b, v, aaa

 integer , allocatable , dimension(:) :: aa , c

 write(*,*) ' ingrese la dimensión de los arreglos .'

 read(*,*) n

 allocate (a(n,n), b(n,1), c(n), v(n,1), aa(n*n), aaa(n,n) )

 b(1:N:2,1) = 3 ! Notar que para fortran N = n

 b(2:N:2,1) = 2

 write (*,*) ''

 write (*,*) 'dimensión n =', n

 write (*,*) ''

 write (*,*) ' vector b =', b

 ! Otra manera de hacer la asignación. ( Array Constructors )

 ! Notar que 'c' es un arreglo unidimensional

 c = (/ (2+mod(i ,2),i=1,n) /)

 write (*,*) ''

 write (*,*) ' c =', c

 write (*,*) ''

 write (*,*) ' ---------------------------------------------------------- '

write (*,*) ''

 ! se define el vector aa

 aa = (/ 3, (0,i=2,n), ( (1,i=1,j-1) ,3,(0,i=j+1,n), j=2,n) /)

 write (*,*) ''

 write (*,*) ' vector aa =', aa

 write (*,*) ' --------------------------------------------------------- '

 ! se cambia el vector a arreglo

 aaa = reshape ((aa) ,(/ n , n /))

  write (*,*) ' arreglo aaa =', aaa

  write (*,*) ' --------------------------------------------------------------------- '

 do i=1,n

 write (*,*) aaa (i ,:)

 end do

 ! Otra manera de hacer la asignaci ón.

 a = 0

 forall (i =1:n, j=2:n, j>i) a(i,j) = 1

 forall (i =1:n) a(i,i) = 3

 write (*,*) ''

 write (*,*) ' ------------------------------------------------------------------------ '

 write (*,*) ''

 write (*,*) ' a(i,j) ='

 do i=1,n

 write (*,*) a(i,:)

 end do

 write (*,*) ' ------------------------------------------------------------------------ '

 write (*,*) ' vector b =', b

  write (*,*) ' --------------------------------------------------------------------------- '

 v = a * b

 write (*,*) ' vector v = a * b :', v

write (*,*) ' --------------------------------------------------------------------------- '

 v = matmul(a,b)

 write (*,*) ''

 write (*,*) 'v = matmul (a,b)'

 write (*,*) ' vector v =', v

 ! ¾Qué pasa si se prueba lo siguiente ?

 ! v = matmul(a,c)

 ! write (*,*) ''

 ! write (*,*) 'matmul(a,c) =', v

 end program


C
      SUBROUTINE FHIRES (N, X, Y, DY, RPAR, IPAR)
      INTEGER N
      DOUBLE PRECISION X, Y, DY
      DIMENSION Y (8), DY (8)
      DY (1) = -1.71D0*Y(1) + 0.43D0*Y(2) + 8.32D0*Y(3) + 0.0007D0
      DY (2) = 1.71D0*Y(1) - 8.75D0*Y(2)
      DY (3) = -10.03D0*Y(3) + 0.43D0*Y(4) + 0.035D0*Y(5)
      DY (4) = 8.32D0*Y(2) + 1.71D0*Y(3) - 1.12D0*Y(4)
      DY (5) = -1.745D0*Y(5) + 0.43D0*Y(6) + 0.43D0*Y(7)
      DY (6) = -280.0D0*Y(6)*Y(8) + 0.69D0*Y(4) + 1.71D0*Y(5) -
     &         0.43D0*Y(6) + 0.69D0*Y(7)
      DY (7) = 280.0D0*Y(6)*Y(8) - 1.81D0*Y(7)
      DY (8) = -DY (7)
      RETURN
      END

      SUBROUTINE JHIRES(N,X,Y,DFY,LDFY,RPAR,IPAR)
C -------- JACOBIAN FOR HIRES PROBLEM --------
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION Y(N),DFY(LDFY,N)
C------ METTRE A ZERO -------
      DO 1 I=1,N
      DO 1 J=1,N
  1   DFY(I,J)=0.D0
C
      DFY(1,1)=  -1.71D0
      DFY(1,2)=   0.43D0
      DFY(1,3)=   + 8.32D0
C
      DFY(2,1)=   1.71D0
      DFY(2,2)=   - 8.75D0
C
      DFY(3,3)=   -10.03D0
      DFY(3,4)=   0.43D0
      DFY(3,5)=   + 0.035D0
C
      DFY(4,2)=    8.32D0
      DFY(4,3)=   + 1.71D0
      DFY(4,4)=   - 1.12D0
C
      DFY(5,5)=   -1.745D0
      DFY(5,6)=   + 0.43D0
      DFY(5,7)=   + 0.43D0
C
      DFY(6,4)=    + 0.69D0
      DFY(6,5)=    + 1.71D0
      DFY(6,6)=    - 0.43D0  -280.0D0*Y(8)
      DFY(6,7)=    + 0.69D0
      DFY(6,8)=     -280.0D0*Y(6)
C
      DFY(7,6)=     280.0D0*Y(8)
      DFY(7,7)=      - 1.81D0
      DFY(7,8)=     280.0D0*Y(6)
C
      DFY(8,6)=    - 280.0D0*Y(8)
      DFY(8,7)=       1.81D0
      DFY(8,8)=    - 280.0D0*Y(6)
      RETURN
      END


OptionalNat = <some:Nat, none:()>;
Table = Nat -> OptionalNat;

letrec fib:Table = (
    letrec plus : Nat->Nat->Nat =
        λ m:Nat n:Nat.
            if iszero m
            then n
            else plus (pred m) (succ n)
        in
    let prd2 = λ n:Nat. pred (pred n) in
    let opt = λ n:OptionalNat.
        case n of <some=m> => m | <none=_> => 0 in
    λ n:Nat.
        if iszero (pred n) then <some=1> as OptionalNat
        else <some=plus (opt (fib (pred n))) (opt (fib (prd2 n)))> as OptionalNat
    ) in
    let f = λn:Nat. {n=n, fibn=fib n} in
    {f 2, f 8, f 10};


! **
! * Provides Tauchen (1986)'s method for discretization of AR(1) processes
! **
module tauchen
    use kinds, only: dp
    use normal_cdf, only: cdf_normal
    implicit none
    private
    public :: tauchen_discretize

    contains

        ! **
        ! * Discretizes an AR(1) process using Tauchen (1986)'s method.
        ! * This function calculates Tauchen points for AR(1) x=(1-rho)mu0 + rho*x_(-1) + u,
        ! * the transition matrix and the CDF of the transition matrix.
        ! *
        ! * Input:
        ! *     - rho: AR(1) autoregressive coefficient
        ! *     - mu0: AR(1) autoregressive coefficient
        ! *     - sigma: AR(1) standard deviation of white noise process u
        ! *     - n: number of grid points
        ! *     - cover_tauchen: number of standard deviations to be covered by the grid
        ! *
        ! * Output:
        ! *     - y: discretized grid for the AR(1) variable
        ! *     - pi: transition matrix of Markov chain
        ! *     - picum: cumulative distribution function of the transition matrix
        ! **
        subroutine tauchen_discretize(y,pi,picum,rho,mu0,sigma,n,cover_tauchen)
            ! Adapted from sub_tauchen by Jesus Fernandez-Villaverde (undated)
            ! cover_tauchen is the number of SD (each side) that one wants
            ! to cover.

            ! April 10, 2013: Adapted by Carlo Zanella to use Applied Statistics
            ! algorithm as66 for computation of the normal cumulative distribution
            ! function.

            implicit none

            integer, intent(in) :: n

            real(dp), intent(in) :: rho, mu0, sigma, cover_tauchen
            real(dp), dimension (n,n), intent(out) :: pi , picum
            real(dp), dimension (n), intent(out) :: y

            integer :: yc, tc, tcc

            real(dp) :: sigy, mu, upp, low

            ! Define the discrete states of the Markov chain
            sigy = sigma/sqrt(1.0-rho**2)

            y(n) = mu0 + cover_tauchen*sigy
            y(1) = mu0 - cover_tauchen*sigy

            do yc = 2, n-1

                y(yc) = y(1)+(y(n)-y(1))*(yc-1.0)/(n-1.0)

            end do

            ! Compute the transition matrix

            do tc = 1,n
                mu = (1-rho)*mu0 + rho*y(tc)
                upp = (y(2)+y(1))/2.0
                upp = (upp-mu)/sigma
                pi(tc,1) = cdf_normal(X=upp)
                low = (y(n)+y(n-1))/2.0
                low = (low-mu)/sigma
                pi(tc,n) = 1.d0-cdf_normal(X=low)

                do tcc = 2, n-1

                    low = (y(tcc-1)+y(tcc))/2.0
                    upp = (y(tcc+1)+y(tcc))/2.0
                    low = (low-mu)/sigma
                    upp = (upp-mu)/sigma
                    pi(tc,tcc) = cdf_normal(X=upp)-cdf_normal(X=low)

                end do
            end do

            ! Compute the CDF of the transition matrix.
            picum(:,1)=pi(:,1)
            do tc = 2,n
                picum(:,tc)=picum(:,tc-1)+pi(:,tc)
            enddo

        end subroutine tauchen_discretize

end module tauchen


function func(x)
real*8::func,x
func=sin(x)
end
program integracion
implicit none
external func
!REGLA TRAPECIO compuesta, necesito una func, un punto inicial 'a', uno final 'b', la cantidad de puntos 'n' incluyendo a y b
!se necesita un vector x(i)
REAL*8::h,a,b,func,U,suma,SUMA1,SUMA2,UU,UUU,UUUU,integral,con1,con2,con3,summa
INTEGER*4::i,n,k,nn,mm,j
REAL*8,ALLOCATABLE,DIMENSION(:)::P,xx,AC,BD,w,hh
REAL*8,ALLOCATABLE,DIMENSION(:,:)::r
a=0d1
b= acos(-1.0)
n=5

h=abs(b-a)/(n-1)
suma=0d1
allocate(P(n))
do i=1,(n-2)
 P(i)=a+h*i
 suma=suma+func(P(i))
end do

U=h*(func(a)+func(b))/2+h*suma
print*, U, 'U'
!regla de simsomp de 3 puntos,

if (n==3) then
do i=1,(n-2)
 P(i)=a+h*i
 suma=suma+func(P(i))
end do
UU=(h/3)*(func(a)+4*func(P(1))+func(b))
print*, UU, '2U'
else if (n>3) then
!regla de simpson 3/8
UUU=((3*h)/8)*(func(a)+func(b)+ 3*(func(a+abs(b-a)/3)+func(a+2*abs(b-a)/3)))
!REGLA DE SIMSOPS COMPUESTA
SUMA1=0d1
SUMA2=0d1
do i=1,INT(n/2)
if (i==INT(n/2)) then
SUMA1=SUMA1+func(P(i*2-1))
else
SUMA2=SUMA2+func(P(i*2))
SUMA1=SUMA1+func(P(i*2-1))
end if
end do

UUUU=(h/3)*(func(a)+func(b)+4*SUMA1+2*SUMA2)
print*, UUU , '3U'
else
print*, 'se usa la del trapecio'
end if
!REGLA DE NEWTON CONTES 2DO ORDEN
 !determinacion de los w(k) en un intervalo b,a con tres puntos
 allocate(xx(3),AC(2),BD(2),w(3))

 xx(0)=0d1
 xx(1)=5d0
 xx(2)=1d1
 do k = 0,2

 do i = 0,2
 if (i.ne.k) then
 	if (i>k) then
 	AC(i) = (xx(k)-xx(i))
 	BD(i)=(xx(i))/(xx(k)-xx(i))
 	ELSE
 	AC(i-1) = (xx(k)-xx(i))
 	BD(i-1)=(xx(i))/(xx(k)-xx(i))
 	end if
 else
 end if
 end do

 con1=AC(1)*AC(2)
 con2=(BD(2)/AC(1))+(BD(1)/AC(2))
 con3=BD(1)*BD(2)

 W(k)=((b-a)**3)/(3*con1)-(((b-a)**2)/2)*con2+(b-a)*con3

 end do

 integral=0
 do i=0,2
 integral=w(i)*func(xx(i))+integral
 end do
 print*, integral,'los w son',w(0),w(1),w(2)

 !------------------------------------------------
 !integracion romberg
 !obtenes una matriz R(nn,mm) donde necesito una funcion que se pueda derivar muhco, un valor inicial, uno final y la cantidad de nn y mm del romberg que quiero.
 nn=6
 mm=6
 allocate(r(nn,mm),hh(nn))
 r(0,0)=(1./2.)*(b-a)*(func(a)+func(b))
 print*, 'a',(1./2.)*(b-a)*(func(a)-func(b)),b,a
 do j=1,6
 do k=1,6
 hh(k)=(b-a)/(2**k)
 summa=0
 do i=1,(2**(k-1))
 summa=summa+func(a+(2*i-1)*hh(k))
 end do
 r(k,0)=(1./2.)*r(k-1,0)+hh(k)*summa
 r(k,j)=(1./((4**j)-1))*((4**j)*(r(k,j-1))-r(k-1,j-1))
 end do
 end do
 print*, 'r'
 do i=1,nn
 print*,r(:,i)
 end do
 print*, 'el r(6,6) es ', r(6,6)
end program


program secant
implicit none
double precision p1,p0,p2,q1,q0,q2,tol,f
integer i,imax
imax=20
tol=1.d-7
write(*,*) 'tol=',tol
p0=0.1
p1=0.3
q0=f(p0)
q1=f(p1)
write(*,*) '           i        p_i             |p_i - p_i-1| '
do i=1,imax
  p2=p1-q1*(p1-p0)/(q1-q0)
  q2=f(p2)
  write(*,*) i,p2,dabs(p2-p1)
  if (q1*q2 .lt. 0.) then
    write(8,*) i,'-'
  else
    write(8,*) i,'+'
  endif
  if (dabs(p2-p1) .lt. tol) then
     stop
  endif
  p0=p1
  p1=p2
  q0=q1
  q1=q2
enddo
stop
end program secant

function f(x)
double precision x,f
f= x + 1- 2 * dsin(pi * x)
return
end function f


      subroutine mapc2m_twisted_torus(blockno,xc,yc,xp,yp,zp,alpha)
      implicit none

      integer blockno
      double precision xc,yc,xp,yp,zp
      double precision alpha, r

      double precision pi, pi2

      common /compi/ pi

      pi2 = 2*pi

      r = 1.d0 + alpha*cos(pi2*(yc + xc))

      xp = r*cos(pi2*xc)
      yp = r*sin(pi2*xc)
      zp = alpha*sin(pi2*(yc + xc))

      end


program ex3p4a
    implicit none
    integer, parameter:: ik=selected_int_kind(11), rk=selected_real_kind(11,100)
    integer(kind=ik)::j
    real(kind=rk) :: res

    print'("Seq. 501...510, base 7")'
    do j=1, 10
        res=korput(int(500+j,ik), int(7,ik))
        print '(i3,": ",f6.4)',500+j, res
    end do
    print*

    print'("Seq. 501...510, base 13")'
    do j=1, 10
        res=korput(int(500+j,ik), int(13,ik))
        print '(i3,": ",f6.4)',500+j, res
    end do

contains
real(kind=rk) function korput(index, base)
    implicit none
    integer(kind=ik), intent(in) :: index, base
    integer(kind=ik) :: i
    real(kind=rk) :: f
    i=index
    korput=0
    f=1
    do
        if(i<=0) exit
        f = f/real(base, rk)
        korput = korput + f*(mod(i,base))
        i=floor(i/real(base, rk))
    end do
end function korput
end program ex3p4a


C$Procedure  VTMV ( Vector transpose times matrix times vector, 3 dim )

      DOUBLE PRECISION FUNCTION VTMV ( V1, MATRIX, V2 )

C$ Abstract
C
C      Multiply the transpose of a 3-dimensional column vector,
C      a 3x3 matrix, and a 3-dimensional column vector.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C      None.
C
C$ Keywords
C
C      MATRIX,  VECTOR
C
C$ Declarations

      DOUBLE PRECISION   V1     (   3 )
      DOUBLE PRECISION   MATRIX ( 3,3 )
      DOUBLE PRECISION   V2     (   3 )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C       V1        I     3 dimensional double precision column vector.
C       MATRIX    I     3x3 double precision matrix.
C       V2        I     3 dimensional double precision column vector.
C
C       The function returns the result of (V1**T * MATRIX * V2 ).
C
C$ Detailed_Input
C
C      V1         This may be any 3-dimensional, double precision
C                 column vector.
C
C      MATRIX     This may be any 3x3, double precision matrix.
C
C      V2         This may be any 3-dimensional, double precision
C                 column vector.
C
C$ Detailed_Output
C
C      The function returns the double precision value of the equation
C      (V1**T * MATRIX * V2 ).
C
C      Notice that VTMV is actually the dot product of the vector
C      resulting from multiplying the transpose of V1 and MATRIX and the
C      vector V2.
C
C$ Parameters
C
C      None.
C
C$ Particulars
C
C      This routine implements the following vector/matrix/vector
C      multiplication:
C
C                      T
C         VTMV = |   V1   | |          |  |  |
C                           |  MATRIX  |  |V2|
C                           |          |  |  |
C
C      V1 is a column vector which becomes a row vector when transposed.
C      V2 is a column vector.
C
C      No checking is performed to determine whether floating point
C      overflow has occurred.
C
C$ Examples
C
C      If  V1 = | 2.0D0 |   MATRIX = |  0.0D0  1.0D0  0.0D0 |
C               |       |            |                      |
C               | 4.0D0 |            | -1.0D0  0.0D0  0.0D0 |
C               |       |            |                      |
C               | 6.0D0 |            |  0.0D0  0.0D0  1.0D0 |
C
C          V2 = | 1.0D0 |
C               |       |
C               | 1.0D0 |
C               |       |
C               | 1.0D0 |
C
C      then function value is equal to 4.0D0.
C
C$ Restrictions
C
C      None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      W.M. Owen       (JPL)
C
C$ Literature_References
C
C      None.
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     3-dimensional vector_transpose times matrix times vector
C
C-&

      INTEGER K,L

      VTMV = 0.D0
      DO K=1,3
         DO L=1,3
            VTMV = VTMV + V1(K) * MATRIX(K,L) * V2(L)
         END DO
      END DO

      RETURN
      END


subroutine MatrixEigenValues(N,C,Eigenvalues)
   use typre
   implicit none
   integer(ip) :: N
   real(rp) :: C(N,N), Eigenvalues(N)

   real(rp) :: Caux(N,N)

   INTEGER          INFO, LWORK
      integer(ip)      :: LDA
      integer(ip) :: LWMAX
      real(rp) ::    WORK(N*N*5)

      Caux = C

      LWMAX = N*N
      LWORK = -1
      CALL DSYEV( 'Vectors', 'Upper', N, Caux, N, Eigenvalues, WORK, LWORK, INFO )
      LWORK = MIN( LWMAX, INT( WORK( 1 ) ) )

      !Solve eingenvalue problem
      CALL DSYEV( 'Vectors', 'Upper', N, Caux, N, EigenValues, WORK, LWORK, INFO )

!       IF( INFO.GT.0 ) THEN
!          call runend('Failed to compute eigenvalues')
!       END IF

end subroutine


program matrix_multiply
   use omp_lib
   use openacc
   implicit none
   integer :: i, j, k, myid, m, n, compiled_for, option
   integer, parameter :: fd = 11
   integer :: t1, t2, dt, count_rate, count_max
   real, allocatable, dimension(:,:) :: a, b, c
   real :: tmp, secs

   open(fd,file='wallclocktime',form='formatted')

   option = compiled_for(fd) ! 1-serial, 2-OpenMP, 3-OpenACC, 4-both

!$omp parallel
!$    myid = OMP_GET_THREAD_NUM()
!$    if (myid .eq. 0) then
!$      write(fd,"('Number of procs is ',i4)") OMP_GET_NUM_THREADS()
!$    endif
!$omp end parallel

   call system_clock(count_max=count_max, count_rate=count_rate)

   do m=1,4    ! compute for different size matrix multiplies

      call system_clock(t1)

      n = 1000*2**(m-1)    ! 1000, 2000, 4000, 8000
      allocate( a(n,n), b(n,n), c(n,n) )

! Initialize matrices
      do j=1,n
         do i=1,n
            a(i,j) = real(i + j)
            b(i,j) = real(i - j)
         enddo
      enddo

!$omp parallel do shared(a,b,c,n,tmp) reduction(+: tmp)
!$acc data copyin(a,b) copy(c)
!$acc kernels
! Compute matrix multiplication.
      do j=1,n
         do i=1,n
            tmp = 0.0  ! enables ACC parallelism for k-loop
            do k=1,n
               tmp = tmp + a(i,k) * b(k,j)
            enddo
            c(i,j) = tmp
         enddo
      enddo
!$acc end kernels
!$acc end data
!$omp end parallel do

      call system_clock(t2)
      dt = t2-t1
      secs = real(dt)/real(count_rate)
      write(fd,"('For n=',i4,', wall clock time is ',f12.2,' seconds')") &
              n, secs

      deallocate(a, b, c)

   enddo

  close(fd)
end program matrix_multiply

integer function compiled_for(fd)
implicit none
integer :: fd
#if defined _OPENMP && defined _OPENACC
  compiled_for = 4
  write(fd,"('This code is compiled with OpenMP & OpenACC')")
#elif defined _OPENACC
  compiled_for = 3
  write(fd,"('This code is compiled with OpenACC')")
#elif defined _OPENMP
  compiled_for = 2
  write(fd,"('This code is compiled with OpenMP')")
#else
  compiled_for = 1
  write(fd,"('This code is compiled for serial operations')")
#endif

end function compiled_for


PROGRAM hilbert

! Demonstration program 1 using the 'quad' package.
! Inversion of 10x10 Hilbert matrix by Cholesky factorization.

! Matrix A has elements a(i,j) = 1/(i+j-1).
! To obtain full accuracy, the elements are all multiplied by
! 9 x 5 x 7 x 11 x 13 x 17 x 19  to make them into integers so
! that the input matrix is exact.   The elements of the inverse
! will be multiplied by this integer at the end.

! The elements of the inverse should all be integers.

! Programmer: Alan Miller

! Latest Fortran 77 revision - 13 September 1986
! Fortran 90 version - 3 December 1996
! Latest revision - 3 October 1999

USE quadruple_precision
IMPLICIT NONE

TYPE (quad) :: a(55), total, exact_start, exact, relerr
REAL (dp)   :: det, scale_factor = 14549535.d0
INTEGER     :: i, j, nrows = 10, ier, ipos, ik, k, kj, kjstart

INTERFACE
  SUBROUTINE qchol(a, nrows, ier)
    USE quadruple_precision
    IMPLICIT NONE
    TYPE (quad), DIMENSION(:), INTENT(IN OUT) :: a
    INTEGER, INTENT(IN)                       :: nrows
    INTEGER, INTENT(OUT)                      :: ier
  END SUBROUTINE qchol
END INTERFACE

! Enter the elements of the Hilbert matrix, storing them in a
! 1-dimensional array up to the diagonal in each row.

ipos = 1
DO i = 1, nrows
  DO j = 1, i
    a(ipos) = quad(scale_factor/(i+j-1), 0._dp)
    ipos = ipos + 1
  END DO
END DO

! Get the Cholesky factorization.

CALL qchol(a, nrows, ier)
IF (ier /= 0) THEN
  WRITE(*, *) 'Error in qchol, number:', ier
  STOP
END IF

! Calculate the determinant by multiplying together the diagonal elements
! of the Cholesky factor, squaring the result, and remembering that each
! element was multiplied by scale_factor.

ipos = 1
det = 1.d0
DO i = 1, nrows
  det = det * a(ipos)%hi
  ipos = ipos + i + 1
END DO
det = det * det / scale_factor**nrows
WRITE(*, 900) det
900 FORMAT(' Determinant = ', g20.12/)

! Now invert the triangular matrix.

ipos = 1
DO i = 1, nrows
  kjstart = 1
  DO j = 1, i
    kj = kjstart
    ik = ipos
    IF (j < i) THEN
      total = quad(0._dp, 0._dp)
      DO k = j, i-1
        total = total - a(ik) * a(kj)
        ik = ik + 1
        kj = kj + k
      END DO
      a(ipos) = total / a(ik)
      ipos = ipos + 1
    ELSE
      a(ipos) = quad(1._dp, 0._dp) / a(ipos)
      ipos = ipos + 1
    END IF
    kjstart = kjstart + j + 1
  END DO
END DO

! We formed A = LL', so the inverse is L**(-T).L**(-1),
! where L**(-T) denotes the transpose of the inverse.

ipos = 1
kjstart = 1
DO i = 1, nrows
  DO j = 1, i
    ik = ipos
    total = quad(0._dp, 0._dp)
    kj = kjstart
    DO k = i, nrows
      total = total + a(ik) * a(kj)
      ik = ik + k
      kj = kj + k
    END DO
    a(ipos) = total * scale_factor
    ipos = ipos + 1
  END DO
  kjstart = kjstart + i + 1
END DO

! Output the result.
! The exact values for an n x n matrix are:-

!  (-1)**(i+j).(n+i-1)!(n+j-1)!
!      -------------------------------------
!      (i+j-1)[(i-1)!(j-1)!]**2.(n-i)!(n-j)!

WRITE(*, 910)
910 FORMAT(' row col         calculated           exact        Rel. error')
ipos = 1
exact_start = quad(100._dp, 0._dp)
DO i = 1, nrows
  exact = exact_start
  DO j = 1, i
    relerr = (a(ipos) - exact) / exact
    WRITE(*, 920) i, j, a(ipos)%hi, exact%hi, relerr%hi
    920 FORMAT(2I4, 2F20.4, g14.5)
    exact = -exact * (10+j)*(10-j)*(i+j-1) / REAL((i+j)*j*j)
    ipos = ipos + 1
  END DO
  exact_start = -exact_start * (10+i)*(10-i) / REAL((i+1)*i)
END DO

STOP
END PROGRAM hilbert

SUBROUTINE qchol(a, nrows, ier)

! Quadruple-precision Cholesky factorization of a +ve definite symmetric
! matrix, stored by rows up to the diagonal.   The input matrix is
! overwritten by the lower-triangular factor L, where A = LL'.

! Arguments:
! a(:)  INPUT.  Array containing the lower triangle of matrix A.
! nrows INPUT.  The number of rows (and columns) in A.
! ier   OUTPUT. Error indicator
!     = 0 if no error detected
!     = 1 if nrows < 1
!     = 2 if matrix not +ve definite

! Programmer: Alan Miller

! Latest revision - 12 September 1986
! Fortran 90 version - 3 December 1996

USE quadruple_precision
IMPLICIT NONE

TYPE (quad), DIMENSION(:), INTENT(IN OUT) :: a
INTEGER, INTENT(IN)                       :: nrows
INTEGER, INTENT(OUT)                      :: ier

! Local variables

INTEGER     :: i, j, ij, ikstart, jk, ik, k
TYPE (quad) :: total

IF (nrows <= 0) THEN
  ier = 1
  RETURN
END IF

ij = 1
ikstart = 1
DO i = 1, nrows
  jk = 1
  DO j = 1, i
    ik = ikstart
    total = a(ij)

! Form the sum  a(i,j) - l(i,k).l(j,k)

    DO k = 1, j-1
      total = total - a(ik) * a(jk)
      ik = ik + 1
      jk = jk + 1
    END DO

! On the diagonal  l(i,i) = sqrt(total)
! Off diagonal     l(i,j) = total/l(j,j)

    IF (i == j) THEN
      IF (total%hi <= 0._dp) THEN
        ier = 2
        RETURN
      END IF
      a(ij) = SQRT(total)
    ELSE
      a(ij) = total / a(jk)
      jk = jk + 1
    END IF
    ij = ij + 1
  END DO

! ikstart = location of first element in row i.

  ikstart = ij
END DO
ier = 0

RETURN
END SUBROUTINE qchol


module wavelet
    private i4_wrap, i4_modp, i4_reflect, i4_periodic

    real(kind=4), parameter :: zero = 1.0E-05

    integer(kind=4), parameter :: p = 3

    real(kind=4), dimension(0:p) :: c = (/ &
                                    0.4829629131445341E+00, &
                                    0.8365163037378079E+00, &
                                    0.2241438680420133E+00, &
                                    -0.1294095225512603E+00/)
contains
    subroutine daub4_transform(n, x, y)

!*****************************************************************************80
!
!! DAUB4_TRANSFORM computes the DAUB4 transform of a vector.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 July 2011
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the dimension of the vector.
!    N must be a power of 2 and at least 4.
!
!    Input, real ( kind = 4 ) X(N), the vector to be transformed.
!
!    Output, real ( kind = 4 ) Y(N), the transformed vector.
!
        implicit none

        integer(kind=4) n
        integer(kind=4), parameter :: p = 3

        real(kind=4), dimension(0:p) :: c = (/ &
                                        0.4829629131445341E+00, &
                                        0.8365163037378079E+00, &
                                        0.2241438680420133E+00, &
                                        -0.1294095225512603E+00/)
        integer(kind=4) i
        integer(kind=4) j
        integer(kind=4) j0
        integer(kind=4) j1
        integer(kind=4) j2
        integer(kind=4) j3
        integer(kind=4) m
        real(kind=4) x(n)
        real(kind=4) y(n)
        real(kind=4) z(n)

        y(1:n) = x(1:n)
        z(1:n) = 0.0E+00

        m = n

        do while (4 <= m)

            i = 1

            do j = 1, m - 1, 2

                j0 = i4_periodic(j, 1, m)
                j1 = i4_periodic(j + 1, 1, m)
                j2 = i4_periodic(j + 2, 1, m)
                j3 = i4_periodic(j + 3, 1, m)

                z(i) = c(0)*y(j0) + c(1)*y(j1) &
                       + c(2)*y(j2) + c(3)*y(j3)

                z(i + m/2) = c(3)*y(j0) - c(2)*y(j1) &
                             + c(1)*y(j2) - c(0)*y(j3)

                i = i + 1

            end do

            y(1:m) = z(1:m)

            m = m/2

        end do

        return
    end subroutine daub4_transform

    subroutine daub4_transform_inverse(n, y, x)

!*****************************************************************************80
!
!! DAUB4_TRANSFORM_INVERSE inverts the DAUB4 transform of a vector.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 July 2011
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the dimension of the vector.
!    N must be a power of 2 and at least 4.
!
!    Input, real ( kind = 4 ) Y(N), the transformed vector.
!
!    Output, real ( kind = 4 ) X(N), the original vector.
!
        implicit none

        integer(kind=4) n
        integer(kind=4), parameter :: p = 3

        real(kind=4), dimension(0:p) :: c = (/ &
                                        0.4829629131445341E+00, &
                                        0.8365163037378079E+00, &
                                        0.2241438680420133E+00, &
                                        -0.1294095225512603E+00/)
        integer(kind=4) i
        integer(kind=4) i0
        integer(kind=4) i1
        integer(kind=4) i2
        integer(kind=4) i3
        integer(kind=4) j
        integer(kind=4) m
        real(kind=4) x(n)
        real(kind=4) y(n)
        real(kind=4) z(n)

        x(1:n) = y(1:n)
        z(1:n) = 0.0E+00

        m = 4

        do while (m <= n)

            j = 1

            do i = 0, m/2 - 1

                i0 = i4_periodic(i, 1, m/2)
                i2 = i4_periodic(i + 1, 1, m/2)

                i1 = i4_periodic(i + m/2, m/2 + 1, m)
                i3 = i4_periodic(i + m/2 + 1, m/2 + 1, m)

                z(j) = c(2)*x(i0) + c(1)*x(i1) &
                       + c(0)*x(i2) + c(3)*x(i3)

                z(j + 1) = c(3)*x(i0) - c(0)*x(i1) &
                           + c(1)*x(i2) - c(2)*x(i3)

                j = j + 2

            end do

            x(1:m) = z(1:m)

            m = m*2

        end do

        return
    end subroutine daub4_transform_inverse

    function i4_modp(i, j)

        !*****************************************************************************80
        !
    !! I4_MODP returns the nonnegative remainder of I4 division.
        !
        !  Discussion:
        !
        !    If
        !      NREM = I4_MODP ( I, J )
        !      NMULT = ( I - NREM ) / J
        !    then
        !      I = J * NMULT + NREM
        !    where NREM is always nonnegative.
        !
        !    The MOD function computes a result with the same sign as the
        !    quantity being divided.  Thus, suppose you had an angle A,
        !    and you wanted to ensure that it was between 0 and 360.
        !    Then mod(A,360) would do, if A was positive, but if A
        !    was negative, your result would be between -360 and 0.
        !
        !    On the other hand, I4_MODP(A,360) is between 0 and 360, always.
        !
        !    An I4 is an integer ( kind = 4 ) value.
        !
        !  Example:
        !
        !        I     J     MOD I4_MODP    Factorization
        !
        !      107    50       7       7    107 =  2 *  50 + 7
        !      107   -50       7       7    107 = -2 * -50 + 7
        !     -107    50      -7      43   -107 = -3 *  50 + 43
        !     -107   -50      -7      43   -107 =  3 * -50 + 43
        !
        !  Licensing:
        !
        !    This code is distributed under the GNU LGPL license.
        !
        !  Modified:
        !
        !    02 March 1999
        !
        !  Author:
        !
        !    John Burkardt
        !
        !  Parameters:
        !
        !    Input, integer ( kind = 4 ) I, the number to be divided.
        !
        !    Input, integer ( kind = 4 ) J, the number that divides I.
        !
        !    Output, integer ( kind = 4 ) I4_MODP, the nonnegative remainder when I is
        !    divided by J.
        !
        implicit none

        integer(kind=4), intent(in) :: i
        integer(kind=4) i4_modp
        integer(kind=4), intent(in) :: j
        integer(kind=4) value

        if (j == 0) then
            write (*, '(a)') ' '
            write (*, '(a)') 'I4_MODP - Fatal error!'
            write (*, '(a,i8)') '  Illegal divisor J = ', j
            stop
        end if

        value = mod(i, j)

        if (value < 0) then
            value = value + abs(j)
        end if

        i4_modp = value

        return
    end function i4_modp

    function i4_wrap(ival, ilo, ihi)

        !*****************************************************************************80
        !
    !! I4_WRAP forces an I4 to lie between given limits by wrapping.
        !
        !  Discussion:
        !
        !    An I4 is an integer ( kind = 4 ) value.
        !
        !    There appears to be a bug in the GFORTRAN compiler which can lead to
        !    erroneous results when the first argument of I4_WRAP is an expression.
        !    In particular:
        !
        !    do i = 1, 3
        !      if ( test ) then
        !        i4 = i4_wrap ( i + 1, 1, 3 )
        !      end if
        !    end do
        !
        !    was, when I = 3, returning I4 = 3.  So I had to replace this with
        !
        !    do i = 1, 3
        !      if ( test ) then
        !        i4 = i + 1
        !        i4 = i4_wrap ( i4, 1, 3 )
        !      end if
        !    end do
        !
        !  Example:
        !
        !    ILO = 4, IHI = 8
        !
        !    I  Value
        !
        !    -2     8
        !    -1     4
        !     0     5
        !     1     6
        !     2     7
        !     3     8
        !     4     4
        !     5     5
        !     6     6
        !     7     7
        !     8     8
        !     9     4
        !    10     5
        !    11     6
        !    12     7
        !    13     8
        !    14     4
        !
        !  Licensing:
        !
        !    This code is distributed under the GNU LGPL license.
        !
        !  Modified:
        !
        !    07 September 2009
        !
        !  Author:
        !
        !    John Burkardt
        !
        !  Parameters:
        !
        !    Input, integer ( kind = 4 ) IVAL, a value.
        !
        !    Input, integer ( kind = 4 ) ILO, IHI, the desired bounds.
        !
        !    Output, integer ( kind = 4 ) I4_WRAP, a "wrapped" version of the value.
        !
        implicit none

        integer(kind=4) i4_wrap
        integer(kind=4), intent(in) :: ihi
        integer(kind=4), intent(in) :: ilo
        integer(kind=4), intent(in) :: ival
        integer(kind=4) jhi
        integer(kind=4) jlo
        integer(kind=4) value
        integer(kind=4) wide

        jlo = min(ilo, ihi)
        jhi = max(ilo, ihi)

        wide = jhi - jlo + 1

        if (wide == 1) then
            value = jlo
        else
            value = jlo + i4_modp(ival - jlo, wide)
        end if

        i4_wrap = value

        return
    end function i4_wrap

    elemental function i4_reflect(ival, ilo, ihi)
        integer(kind=4) :: i4_reflect
        integer(kind=4), intent(in) :: ival, ilo, ihi
        integer(kind=4) :: value
        integer(kind=4) :: dist

        ! the default return value
        value = ival

        ! the upper boundary
        if (ival .gt. ihi) then
            dist = ival - ihi
            value = ihi - (dist - 1)
        end if

        ! the lower boundary
        if (ival .lt. ilo) then
            dist = ilo - ival
            value = ilo + (dist - 1)
        end if

        i4_reflect = value

        return
    end function i4_reflect

    elemental function i4_periodic(ival, ilo, ihi)
        integer(kind=4) :: i4_periodic
        integer(kind=4), intent(in) :: ival, ilo, ihi
        integer(kind=4) :: value
        integer(kind=4) :: dist

        ! the default return value
        value = ival

        ! the upper boundary
        if (ival .gt. ihi) then
            dist = ival - ihi
            value = ilo + (dist - 1)
        end if

        ! the lower boundary
        if (ival .lt. ilo) then
            dist = ilo - ival
            value = ihi - (dist - 1)
        end if

        i4_periodic = value

        return
    end function i4_periodic

    subroutine daub4_2Dtransform(n, x, y, mask, create_mask)
!********************************
! a 2D DAUB4 wavelet transform of a square floating-point matrix
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Author:
!
!  Christopher Zapart, based on the 1D code by John Burkardt
!
!  Input, integer (kind = 4) N, the dimension of the square block N x N
!    N must be a power of 2 and at least 4.
!
!  Input, real (kind = 4) X(N,N), the original square matrix to be transformed
!
!  Output, real (kind = 4) Y(N,N), the wavelet-transformed matrix
!
! Output, logical mask(N,N), a boolean matrix where .false. indicates NaN values in X
!
! Input: logical create_mask - whether or not to creater or re-use the given mask
! instead of creating it from scratch
!
        implicit none

        integer(kind=4) :: n
        integer(kind=4), parameter :: p = 3
        real(kind=4), parameter :: zero = 1.0E-05

        real(kind=4), dimension(0:p) :: c = (/ &
                                        0.4829629131445341E+00, &
                                        0.8365163037378079E+00, &
                                        0.2241438680420133E+00, &
                                        -0.1294095225512603E+00/)
        integer(kind=4) i
        integer(kind=4) j
        integer(kind=4) j0
        integer(kind=4) j1
        integer(kind=4) j2
        integer(kind=4) j3

        integer(kind=4) m
        real(kind=4), dimension(n, n), intent(in) :: x
        real(kind=4), dimension(n, n), intent(out) :: y
        logical(kind=1), optional, dimension(n, n), intent(inout) :: mask
        logical, optional, intent(in) :: create_mask
        real(kind=4), dimension(n) :: z
        real(kind=4) average
        integer(kind=4) nvalid
        integer(kind=4) k

        y = x
        z = 0.0E+00

        if (present(mask)) then
            block
                logical need_mask

                if (present(create_mask)) then
                    need_mask = create_mask
                else
                    need_mask = .true.
                end if

                if (need_mask) then
                    !  pick out all the NaN
                    where (isnan(x))
                        mask = .false.
                    elsewhere
                        mask = .true.
                    end where
                end if

                ! calculate the mean of the input array
                nvalid = count(mask)

                ! all values might be NaN in which case set the array to 0.0
                if (nvalid .gt. 0) then
                    average = sum(x, mask=mask)/nvalid
                else
                    average = 0.0
                end if

                ! replace NaNs with the average value
                where (.not. mask) y = average
            end block
        end if

        m = n

        ! for each level
        do while (m .ge. 4)
            ! transform all the rows
            do k = 1, m
                i = 1

                do j = 1, m - 1, 2

                    j0 = i4_periodic(j, 1, m)
                    j1 = i4_periodic(j + 1, 1, m)
                    j2 = i4_periodic(j + 2, 1, m)
                    j3 = i4_periodic(j + 3, 1, m)

                    z(i) = c(0)*y(k, j0) + c(1)*y(k, j1) &
                           + c(2)*y(k, j2) + c(3)*y(k, j3)

                    z(i + m/2) = c(3)*y(k, j0) - c(2)*y(k, j1) &
                                 + c(1)*y(k, j2) - c(0)*y(k, j3)

                    i = i + 1

                end do

                y(k, 1:m) = z(1:m)
            end do

            ! then the columns
            do k = 1, m
                i = 1

                do j = 1, m - 1, 2

                    j0 = i4_periodic(j, 1, m)
                    j1 = i4_periodic(j + 1, 1, m)
                    j2 = i4_periodic(j + 2, 1, m)
                    j3 = i4_periodic(j + 3, 1, m)

                    z(i) = c(0)*y(j0, k) + c(1)*y(j1, k) &
                           + c(2)*y(j2, k) + c(3)*y(j3, k)

                    z(i + m/2) = c(3)*y(j0, k) - c(2)*y(j1, k) &
                                 + c(1)*y(j2, k) - c(0)*y(j3, k)

                    i = i + 1

                end do

                y(1:m, k) = z(1:m)
            end do

            m = m/2
        end do

        ! truncate values near zero
        where (abs(y) < zero) y = 0.0

        return
    end subroutine daub4_2Dtransform

    subroutine daub4_2Dtransform_inv(n, y, x, mask)
        !********************************
        ! a 2D DAUB4 inverse wavelet transform of a square floating-point matrix
        !
        !  Licensing:
        !
        !    This code is distributed under the GNU LGPL license.
        !
        !  Author:
        !
        !  Christopher Zapart, based on the 1D code by John Burkardt
        !
        !  Input, integer (kind = 4) N, the dimension of the square block N x N
        !    N must be a power of 2 and at least 4.
        !
        !  Input, real (kind = 4) Y(N,N), the wavelet-transformed square matrix
        !
        !  Output, real (kind = 4) X(N,N), the original matrix
        !
        use, intrinsic :: ieee_arithmetic
        implicit none

        integer(kind=4) n
        integer(kind=4), parameter :: p = 3

        real(kind=4), dimension(0:p) :: c = (/ &
                                        0.4829629131445341E+00, &
                                        0.8365163037378079E+00, &
                                        0.2241438680420133E+00, &
                                        -0.1294095225512603E+00/)
        integer(kind=4) i
        integer(kind=4) i0
        integer(kind=4) i1
        integer(kind=4) i2
        integer(kind=4) i3
        integer(kind=4) j
        integer(kind=4) m
        logical(kind=1), optional, dimension(n, n), intent(in) :: mask
        real(kind=4), dimension(n, n), intent(out) :: x
        real(kind=4), dimension(n, n), intent(in) :: y
        real(kind=4), dimension(n) :: z

        integer(kind=4) k

        x = y
        z = 0.0E+00

        m = 4

        ! for each level
        do while (m .le. n)
            ! reverse all the columns
            do k = 1, m
                j = 1

                do i = 0, m/2 - 1

                    i0 = i4_periodic(i, 1, m/2)
                    i2 = i4_periodic(i + 1, 1, m/2)

                    i1 = i4_periodic(i + m/2, m/2 + 1, m)
                    i3 = i4_periodic(i + m/2 + 1, m/2 + 1, m)

                    z(j) = c(2)*x(i0, k) + c(1)*x(i1, k) &
                           + c(0)*x(i2, k) + c(3)*x(i3, k)

                    z(j + 1) = c(3)*x(i0, k) - c(0)*x(i1, k) &
                               + c(1)*x(i2, k) - c(2)*x(i3, k)

                    j = j + 2

                end do

                x(1:m, k) = z(1:m)
            end do

            ! then the rows
            do k = 1, m
                j = 1

                do i = 0, m/2 - 1

                    i0 = i4_periodic(i, 1, m/2)
                    i2 = i4_periodic(i + 1, 1, m/2)

                    i1 = i4_periodic(i + m/2, m/2 + 1, m)
                    i3 = i4_periodic(i + m/2 + 1, m/2 + 1, m)

                    z(j) = c(2)*x(k, i0) + c(1)*x(k, i1) &
                           + c(0)*x(k, i2) + c(3)*x(k, i3)

                    z(j + 1) = c(3)*x(k, i0) - c(0)*x(k, i1) &
                               + c(1)*x(k, i2) - c(2)*x(k, i3)

                    j = j + 2

                end do

                x(k, 1:m) = z(1:m)
            end do

            m = m*2
        end do

        ! insert back NaN values
        if (present(mask)) then
            where (.not. mask) x = ieee_value(0.0, ieee_quiet_nan)
        end if

        return
    end subroutine daub4_2Dtransform_inv

! in-place versions
    subroutine daub4_2Dtransform_inpl(n, x, mask, create_mask)
        !********************************
        ! a 2D DAUB4 wavelet transform of a square floating-point matrix (in-place)
        !
        !  Licensing:
        !
        !    This code is distributed under the GNU LGPL license.
        !
        !  Author:
        !
        !  Christopher Zapart, based on the 1D code by John Burkardt
        !
        !  Input, integer (kind = 4) N, the dimension of the square block N x N
        !    N must be a power of 2 and at least 4.
        !
        !  Input and Output, real (kind = 4) X(N,N), the original square matrix to be transformed
        !
        ! Output, logical mask(N,N), a boolean matrix where .false. indicates NaN values in X
        !
        !  the output is stored in-place
        !
        ! Input: logical create_mask - whether or not to creater or re-use the given mask
        ! instead of creating it from scratch
        !
        implicit none

        integer(kind=4) :: n
        integer(kind=4), parameter :: p = 3
        real(kind=4), parameter :: zero = 1.0E-05

        real(kind=4), dimension(0:p) :: c = (/ &
                                        0.4829629131445341E+00, &
                                        0.8365163037378079E+00, &
                                        0.2241438680420133E+00, &
                                        -0.1294095225512603E+00/)
        integer(kind=4) i
        integer(kind=4) j
        integer(kind=4) j0
        integer(kind=4) j1
        integer(kind=4) j2
        integer(kind=4) j3

        integer(kind=4) m
        real(kind=4), dimension(n, n), intent(inout) :: x
        logical(kind=1), optional, dimension(n, n), intent(inout) :: mask
        logical, optional, intent(in) :: create_mask
        real(kind=4), dimension(n) :: z
        real(kind=4) average
        integer(kind=4) nvalid
        integer(kind=4) k

        z = 0.0E+00

        if (present(mask)) then
            block
                logical need_mask

                if (present(create_mask)) then
                    need_mask = create_mask
                else
                    need_mask = .true.
                end if

                if (need_mask) then
                    !  pick out all the NaN
                    where (isnan(x))
                        mask = .false.
                    elsewhere
                        mask = .true.
                    end where
                end if

                ! calculate the mean of the input array
                nvalid = count(mask)

                ! all values might be NaN in which case set the array to 0.0
                if (nvalid .gt. 0) then
                    average = sum(x, mask=mask)/nvalid
                else
                    average = 0.0
                end if

                ! replace NaNs with the average value
                where (.not. mask) x = average
            end block
        end if

        m = n

        ! for each level
        do while (m .ge. 4)
            ! transform all the rows
            do k = 1, m
                i = 1

                do j = 1, m - 1, 2

                    j0 = i4_periodic(j, 1, m)
                    j1 = i4_periodic(j + 1, 1, m)
                    j2 = i4_periodic(j + 2, 1, m)
                    j3 = i4_periodic(j + 3, 1, m)

                    z(i) = c(0)*x(k, j0) + c(1)*x(k, j1) &
                           + c(2)*x(k, j2) + c(3)*x(k, j3)

                    z(i + m/2) = c(3)*x(k, j0) - c(2)*x(k, j1) &
                                 + c(1)*x(k, j2) - c(0)*x(k, j3)

                    i = i + 1

                end do

                x(k, 1:m) = z(1:m)
            end do

            ! then the columns
            do k = 1, m
                i = 1

                do j = 1, m - 1, 2

                    j0 = i4_periodic(j, 1, m)
                    j1 = i4_periodic(j + 1, 1, m)
                    j2 = i4_periodic(j + 2, 1, m)
                    j3 = i4_periodic(j + 3, 1, m)

                    z(i) = c(0)*x(j0, k) + c(1)*x(j1, k) &
                           + c(2)*x(j2, k) + c(3)*x(j3, k)

                    z(i + m/2) = c(3)*x(j0, k) - c(2)*x(j1, k) &
                                 + c(1)*x(j2, k) - c(0)*x(j3, k)

                    i = i + 1

                end do

                x(1:m, k) = z(1:m)
            end do

            m = m/2
        end do

        ! truncate values near zero
        where (abs(x) .lt. zero) x = 0.0

        return
    end subroutine daub4_2Dtransform_inpl

    subroutine daub4_2Dtransform_inv_inpl(n, x, mask)
        !********************************
        ! a 2D DAUB4 inverse wavelet transform of a square floating-point matrix (in-place)
        !
        !  Licensing:
        !
        !    This code is distributed under the GNU LGPL license.
        !
        !  Author:
        !
        !  Christopher Zapart, based on the 1D code by John Burkardt
        !
        !  Input, integer (kind = 4) N, the dimension of the square block N x N
        !    N must be a power of 2 and at least 4.
        !
        !  Input and Output, real (kind = 4) X(N,N), the wavelet-transformed square matrix
        !
        !  the output is stored in-place in x
        !
        use, intrinsic :: ieee_arithmetic
        implicit none

        integer(kind=4) n
        integer(kind=4), parameter :: p = 3

        real(kind=4), dimension(0:p) :: c = (/ &
                                        0.4829629131445341E+00, &
                                        0.8365163037378079E+00, &
                                        0.2241438680420133E+00, &
                                        -0.1294095225512603E+00/)
        integer(kind=4) i
        integer(kind=4) i0
        integer(kind=4) i1
        integer(kind=4) i2
        integer(kind=4) i3
        integer(kind=4) j
        integer(kind=4) m
        real(kind=4), dimension(n, n), intent(inout) :: x
        logical(kind=1), optional, dimension(n, n), intent(in) :: mask
        real(kind=4), dimension(n) :: z

        integer(kind=4) k

        z = 0.0E+00

        m = 4

        ! for each level
        do while (m .le. n)
            ! reverse all the columns
            do k = 1, m
                j = 1

                do i = 0, m/2 - 1

                    i0 = i4_periodic(i, 1, m/2)
                    i2 = i4_periodic(i + 1, 1, m/2)

                    i1 = i4_periodic(i + m/2, m/2 + 1, m)
                    i3 = i4_periodic(i + m/2 + 1, m/2 + 1, m)

                    z(j) = c(2)*x(i0, k) + c(1)*x(i1, k) &
                           + c(0)*x(i2, k) + c(3)*x(i3, k)

                    z(j + 1) = c(3)*x(i0, k) - c(0)*x(i1, k) &
                               + c(1)*x(i2, k) - c(2)*x(i3, k)

                    j = j + 2

                end do

                x(1:m, k) = z(1:m)
            end do

            ! then the rows
            do k = 1, m
                j = 1

                do i = 0, m/2 - 1

                    i0 = i4_periodic(i, 1, m/2)
                    i2 = i4_periodic(i + 1, 1, m/2)

                    i1 = i4_periodic(i + m/2, m/2 + 1, m)
                    i3 = i4_periodic(i + m/2 + 1, m/2 + 1, m)

                    z(j) = c(2)*x(k, i0) + c(1)*x(k, i1) &
                           + c(0)*x(k, i2) + c(3)*x(k, i3)

                    z(j + 1) = c(3)*x(k, i0) - c(0)*x(k, i1) &
                               + c(1)*x(k, i2) - c(2)*x(k, i3)

                    j = j + 2

                end do

                x(k, 1:m) = z(1:m)
            end do

            m = m*2
        end do

        ! insert back NaN values
        if (present(mask)) then
            where (.not. mask) x = ieee_value(0.0, ieee_quiet_nan)
        end if

        return
    end subroutine daub4_2Dtransform_inv_inpl

    pure subroutine to_daub4_block(x, mask, create_mask)
        !********************************
        ! a 2D DAUB4 wavelet transform of a square floating-point matrix (in-place)
        !
        !  Licensing:
        !
        !    This code is distributed under the GNU LGPL license.
        !
        !  Author:
        !
        !  Christopher Zapart, based on the 1D code by John Burkardt
        !
        !  Fixed block dimension N = 4, the dimension of the square block 4 x 4
        !
        !  Input and Output, real (kind = 4) X(4,4), the original square matrix to be transformed
        !
        ! Output, logical mask(4,4), a boolean matrix where .false. indicates NaN values in X
        !
        !  the output is stored in-place
        !
        ! Input: logical create_mask - whether or not to creater or re-use the given mask
        ! instead of creating it from scratch
        !
        implicit none

        integer(kind=4) i
        integer(kind=4) j
        integer(kind=4) j0
        integer(kind=4) j1
        integer(kind=4) j2
        integer(kind=4) j3

        real(kind=4), dimension(4, 4), intent(inout) :: x
        logical(kind=1), optional, dimension(4, 4), intent(inout) :: mask
        logical, optional, intent(in) :: create_mask
        real(kind=4), dimension(4) :: z
        real(kind=4) average
        integer(kind=4) nvalid
        integer(kind=4) k

        z = 0.0E+00

        if (present(mask)) then
            block
                logical need_mask

                if (present(create_mask)) then
                    need_mask = create_mask
                else
                    need_mask = .true.
                end if

                if (need_mask) then
                    !  pick out all the NaN
                    where (isnan(x))
                        mask = .false.
                    elsewhere
                        mask = .true.
                    end where
                end if

                ! calculate the mean of the input array
                nvalid = count(mask)

                ! all values might be NaN in which case set the array to 0.0
                if (nvalid .gt. 0) then
                    average = sum(x, mask=mask)/nvalid
                else
                    average = 0.0
                end if

                ! replace NaNs with the average value
                where (.not. mask) x = average
            end block
        end if

        ! do only one iteration as n .eq. 4

        ! transform all the rows
        do k = 1, 4
            i = 1

            do j = 1, 4 - 1, 2

                j0 = i4_periodic(j, 1, 4)
                j1 = i4_periodic(j + 1, 1, 4)
                j2 = i4_periodic(j + 2, 1, 4)
                j3 = i4_periodic(j + 3, 1, 4)

                z(i) = c(0)*x(k, j0) + c(1)*x(k, j1) &
                       + c(2)*x(k, j2) + c(3)*x(k, j3)

                z(i + 2) = c(3)*x(k, j0) - c(2)*x(k, j1) &
                           + c(1)*x(k, j2) - c(0)*x(k, j3)

                i = i + 1

            end do

            x(k, 1:4) = z(1:4)
        end do

        ! then the columns
        do k = 1, 4
            i = 1

            do j = 1, 4 - 1, 2

                j0 = i4_periodic(j, 1, 4)
                j1 = i4_periodic(j + 1, 1, 4)
                j2 = i4_periodic(j + 2, 1, 4)
                j3 = i4_periodic(j + 3, 1, 4)

                z(i) = c(0)*x(j0, k) + c(1)*x(j1, k) &
                       + c(2)*x(j2, k) + c(3)*x(j3, k)

                z(i + 2) = c(3)*x(j0, k) - c(2)*x(j1, k) &
                           + c(1)*x(j2, k) - c(0)*x(j3, k)

                i = i + 1

            end do

            x(1:4, k) = z(1:4)
        end do

        ! truncate values near zero
        where (abs(x) .lt. zero) x = 0.0

        return
    end subroutine to_daub4_block

    pure subroutine from_daub4_block(x, mask)
        !********************************
        ! a 2D DAUB4 inverse wavelet transform of a square floating-point matrix (in-place)
        !
        !  Licensing:
        !
        !    This code is distributed under the GNU LGPL license.
        !
        !  Author:
        !
        !  Christopher Zapart, based on the 1D code by John Burkardt
        !
        !  Fixed block dimension N = 4, the dimension of the square block 4 x 4
        !
        !  Input and Output, real (kind = 4) X(4,4), the wavelet-transformed square matrix
        !
        !  the output is stored in-place in x
        !
        use, intrinsic :: ieee_arithmetic
        implicit none

        integer(kind=4) i
        integer(kind=4) i0
        integer(kind=4) i1
        integer(kind=4) i2
        integer(kind=4) i3
        integer(kind=4) j
        real(kind=4), dimension(4, 4), intent(inout) :: x
        logical(kind=1), optional, dimension(4, 4), intent(in) :: mask
        real(kind=4), dimension(4) :: z

        integer(kind=4) k

        z = 0.0E+00

        ! do only one iteration as n .eq. 4

        ! reverse all the columns
        do k = 1, 4
            j = 1

            do i = 0, 2 - 1

                i0 = i4_periodic(i, 1, 2)
                i2 = i4_periodic(i + 1, 1, 2)

                i1 = i4_periodic(i + 2, 2 + 1, 4)
                i3 = i4_periodic(i + 2 + 1, 2 + 1, 4)

                z(j) = c(2)*x(i0, k) + c(1)*x(i1, k) &
                       + c(0)*x(i2, k) + c(3)*x(i3, k)

                z(j + 1) = c(3)*x(i0, k) - c(0)*x(i1, k) &
                           + c(1)*x(i2, k) - c(2)*x(i3, k)

                j = j + 2

            end do

            x(1:4, k) = z(1:4)
        end do

        ! then the rows
        do k = 1, 4
            j = 1

            do i = 0, 2 - 1

                i0 = i4_periodic(i, 1, 2)
                i2 = i4_periodic(i + 1, 1, 2)

                i1 = i4_periodic(i + 2, 2 + 1, 4)
                i3 = i4_periodic(i + 2 + 1, 2 + 1, 4)

                z(j) = c(2)*x(k, i0) + c(1)*x(k, i1) &
                       + c(0)*x(k, i2) + c(3)*x(k, i3)

                z(j + 1) = c(3)*x(k, i0) - c(0)*x(k, i1) &
                           + c(1)*x(k, i2) - c(2)*x(k, i3)

                j = j + 2

            end do

            x(k, 1:4) = z(1:4)
        end do

        ! insert back NaN values
        if (present(mask)) then
            where (.not. mask) x = ieee_value(0.0, ieee_quiet_nan)
        end if

        return
    end subroutine from_daub4_block

    subroutine wave_shrink(n, x)
        implicit none

        integer(kind=4) :: n
        real(kind=4), dimension(n, n), intent(inout) :: x
        integer(kind=4) :: i, j, nvalid
        real(kind=4) mean, std, tmp

        if (n .lt. 4) return

        ! calculate the mean and standard deviation of
        ! absolute values of detail coefficients (skipping the coarse coeffs)

        mean = 0.0
        std = 0.0
        nvalid = 0

        ! the mean
        do j = 1, n
            do i = 1, n
                ! skip the coarse coefficients
                if ((i .le. 4/2) .and. (j .le. 4/2)) cycle

                tmp = abs(x(i, j))
                ! only process non-zero values
                if (tmp .gt. 0.0) then
                    mean = mean + tmp
                    nvalid = nvalid + 1
                end if
            end do
        end do

        if (nvalid .gt. 0) then
            mean = mean/nvalid
        else
            return
        end if

        ! do nothing if all values are 0.0
        if (mean .eq. 0.0) return

        ! the standard deviation
        do j = 1, n
            do i = 1, n
                ! skip the coarse coefficients
                if ((i .le. 2) .and. (j .le. 2)) cycle

                tmp = abs(x(i, j))
                ! only process non-zero values
                if (tmp .gt. 0.0) std = std + (tmp - mean)**2
            end do
        end do

        if ((nvalid - 1) .gt. 0) then
            std = sqrt(std/(nvalid - 1))
        else if (nvalid .gt. 0) then
            ! nvalid .eq. 1 at this point (there is no point in dividing by 1)
            std = sqrt(std/nvalid)
        else
            return
        end if

        print *, '[wave_shrink] mean:', mean, 'std:', std

        ! prune (shrink the coefficients)
        do j = 1, n
            do i = 1, n
                ! skip the coarse coefficients
                if ((i .le. 2) .and. (j .le. 2)) cycle

                ! set the small coefficients (one half to be precise) to 0.0
                if (abs(x(i, j)) .le. mean - 0.5*std) x(i, j) = 0.0
            end do
        end do

    end subroutine wave_shrink

    subroutine wave_shrink2(n, x)
        implicit none

        integer(kind=4) :: n
        real(kind=4), dimension(n, n), intent(inout) :: x
        integer(kind=4) :: i, j, nvalid
        real(kind=4) mean, std, tmp

        if (n .lt. 4) return

        ! calculate the mean and standard deviation of
        ! of detail coefficients (skipping the coarse coeffs)

        mean = 0.0
        std = 0.0

        ! the mean
        do j = 1, n
            do i = 1, n
                ! skip the coarse coefficients
                if ((i .le. 4/2) .and. (j .le. 4/2)) cycle

                mean = mean + x(i, j)
                nvalid = nvalid + 1
            end do
        end do

        if (nvalid .gt. 0) then
            mean = mean/nvalid
        else
            return
        end if

        ! do nothing if all values are 0.0
        if (mean .eq. 0.0) return

        ! the standard deviation
        do j = 1, n
            do i = 1, n
                ! skip the coarse coefficients
                if ((i .le. 2) .and. (j .le. 2)) cycle

                tmp = x(i, j)
                std = std + (tmp - mean)*(tmp - mean)
            end do
        end do

        if ((nvalid - 1) .gt. 0) then
            std = sqrt(std/(nvalid - 1))
        else if (nvalid .gt. 0) then
            ! I know nvalid .eq. 1 at this point (there is no point dividing by 1)
            std = sqrt(std/nvalid)
        else
            return
        end if

        print *, 'mean:', mean, 'std:', std

        ! prune (shrink the coefficients)
        do j = 1, n
            do i = 1, n
                ! skip the coarse coefficients
                if ((i .le. 2) .and. (j .le. 2)) cycle

                ! set the small coefficients to 0.0
                tmp = x(i, j)
                if ((tmp .gt. (mean - 0.25*std)) .and. (tmp .lt. (mean + 0.25*std))) x(i, j) = 0.0
            end do
        end do

    end subroutine wave_shrink2
end module wavelet


program test_eig
use types, only: dp
use utils, only: assert
use linalg, only: eig, eye
use constants, only : i_
implicit none

! test eigenvalue comutation for general matrices:

real(dp), parameter :: eps = 1e-9_dp
real(dp) :: A(2, 2), B(5, 5)
complex(dp) :: AC(2, 2), lam(2), c(2, 2), r(2), n, lamb(5), cb(5, 5)
integer :: i

! test a matrix with complex eigenvalues/eigenvectors:
A = reshape([1, -1, 2, 1], shape=[2, 2])  ! lambda_i = 1 \pm \sqrt(2) i
call eig(A, lam, c)
! TODO: add test for correctness of eigenvalues
do i = 1, 2
    ! Test proper norm of eigenvectors:
    n = dot_product(c(:,i), c(:,i))
    call assert(abs(n - 1) < eps)
    ! Test that c(:, i) is an eigenvector with eigenvalue lam(i):
    r = matmul(A-lam(i)*eye(2), c(:, i))
    call assert(sqrt(abs(dot_product(r, r))) < eps)
end do

! test a multiple of the unit matrix:
B = 3*eye(5)
call eig(B, lamb, cb)
call assert(maxval(abs(lamb - 3.0_dp)) < eps)  ! all eigenvalues are 3
call assert(maxval(abs(cb - eye(5))) < eps)  ! eigenvectors are cartesian unit basis vectors

! test complex matrices:
AC = reshape([1.0_dp+0*i_, 2*i_, 3*i_, -4.0_dp+0*i_], shape=[2,2])
call eig(AC, lam, c)
call assert(all(abs(lam - [-1.0_dp, -2.0_dp]) < eps))
do i = 1, 2
    ! Test proper norm of eigenvectors:
    n = dot_product(c(:,i), c(:,i))
    call assert(abs(n - 1) < eps)
    ! Test that c(:, i) is an eigenvector with eigenvalue lam(i):
    r = matmul(AC-lam(i)*eye(2), c(:, i))
    call assert(sqrt(abs(dot_product(r, r))) < eps)
end do

end program


module gausslobatto_mod

integer, parameter :: RP = selected_real_kind(15)
real(rp), parameter :: PI = 4.0_rp * atan(1.0_rp)
real(rp), parameter :: TOL = 4.0e-16_rp

!! CONTAINS

!! SUBROUTINE LegendrePolynomialAndDerivativeAlbert(N,x,L_N,dL_N)
!!     IMPLICIT NONE
!!     INTEGER, INTENT(IN)         :: N
!!     REAL(KIND=RP), INTENT(IN)   :: x
!!     REAL(KIND=RP), INTENT(OUT)  :: L_N,dL_N
!! !
!!     ! lokale Variablen
!!     INTEGER                     :: k
!!     REAL(KIND=RP)               :: L_N_1,L_N_2,dL_N_1,dL_N_2
!! !
!!     ! Fuer den einfachsten Fall explizit vorgeben
!!     IF (N.EQ.0) THEN
!!         L_N = 0.0_RP
!!         dL_N = 0.0_RP
!! !
!!     !  Ebenso fuer den zweit-einfachsten Fall
!!     ELSE IF (N.EQ.1) THEN
!!         L_N = x
!!         dL_N = 1.0_RP
!! !
!!     ! Ansonsten auf die 3-Term-Rekursion zurueckgreifen
!!     ELSE
!!         ! Dazu wieder die beiden ersten Polynome vorgeben
!!         L_N_2 = 1.0_RP
!!         L_N_1 = x
!!         dL_N_2 = 0.0_RP
!!         dL_N_1 = 1.0_RP
!! !
!!     DO k=2,N
!!         ! Rekursionsformel fuer die Legendre-Polynome verwenden
!!         L_N = ( (2.0_RP*REAL(k,RP)-1.0_RP) / REAL(k,RP) ) * x * L_N_1 - (REAL(k,RP)-1.0_RP) / REAL(k,RP) * L_N_2
!!         ! Rekursionsformel fuer die Ableitungen verwenden
!!         dL_N = dL_N_2 + ( 2.0_RP*REAL(k,RP) - 1.0_RP ) * L_N_1
!!         ! Werte fuer den naechsten Schritt updaten
!!         L_N_2 = L_N_1
!!         L_N_1 = L_N
!!         dL_N_2 = dL_N_1
!!         dL_N_1 = dL_N
!!     END DO
!! !
!!     END IF
!! !
!!     RETURN
!! END SUBROUTINE
!!
!! ELEMENTAL SUBROUTINE LegendrePolynomialAndDerivative(N_in,x,L,Lder)
!! IMPLICIT NONE
!! !----------------------------------------------------------------------------------------------------------------------------------
!! ! INPUT/OUTPUT VARIABLES
!! INTEGER,INTENT(IN) :: N_in   !< (IN)  polynomial degree, (N+1) CLpoints
!! REAL,INTENT(IN)    :: x      !< (IN)  coordinate value in the interval [-1,1]
!! REAL,INTENT(OUT)   :: L      !< (OUT) Legedre polynomial evaluated at \f$ \xi: L_N(\xi), \partial/\partial\xi L_N(\xi) \f$
!! REAL,INTENT(OUT)   :: Lder   !< (OUT) Legedre polynomial deriv. evaluated at \f$ \xi: L_N(\xi), \partial/\partial\xi L_N(\xi) \f$
!! !----------------------------------------------------------------------------------------------------------------------------------
!! ! LOCAL VARIABLES
!! INTEGER :: iLegendre
!! REAL    :: L_Nm1,L_Nm2 ! L_{N_in-2},L_{N_in-1}
!! REAL    :: Lder_Nm1,Lder_Nm2 ! Lder_{N_in-2},Lder_{N_in-1}
!! !==================================================================================================================================
!! IF(N_in .EQ. 0)THEN
!!   L=1.
!!   Lder=0.
!! ELSEIF(N_in .EQ. 1) THEN
!!   L=x
!!   Lder=1.
!! ELSE ! N_in > 1
!!   L_Nm2=1.
!!   L_Nm1=x
!!   Lder_Nm2=0.
!!   Lder_Nm1=1.
!!   DO iLegendre=2,N_in
!!     L=(REAL(2*iLegendre-1)*x*L_Nm1 - REAL(iLegendre-1)*L_Nm2)/REAL(iLegendre)
!!     Lder=Lder_Nm2 + REAL(2*iLegendre-1)*L_Nm1
!!     L_Nm2=L_Nm1
!!     L_Nm1=L
!!     Lder_Nm2=Lder_Nm1
!!     Lder_Nm1=Lder
!!   END DO !iLegendre=2,N_in
!! END IF ! N_in
!! !normalize
!! L=L*SQRT(REAL(N_in)+0.5)
!! Lder=Lder*SQRT(REAL(N_in)+0.5)
!! END SUBROUTINE LegendrePolynomialAndDerivative
!!
!!
!!
!! !
!! ! ------------------------------------------------------------------------------------------------------------- !
!! !
!!     SUBROUTINE LegendreGaussNodesAndWeights(N,x,w)
!!         IMPLICIT NONE
!!         INTEGER, INTENT(IN)                         :: N
!!         REAL(KIND=RP), DIMENSION(0:N), INTENT(OUT)  :: x,w
!!     !
!!         ! lokale Variablen
!!         INTEGER, PARAMETER                          :: n_it = 4
!!         INTEGER                                     :: j,k
!!         REAL(KIND=RP), PARAMETER                    :: tol = 4.0E-16
!!         REAL(KIND=RP)                               :: L_N,dL_N,Delta
!!
!!         L_N = 0.0
!!         dL_N = 0.0
!!     !
!!         ! Fuer den einfachsten Fall Knoten und Gewicht explizit angeben
!!         IF (N.EQ.0) THEN
!!             x(0) = 0.0_RP
!!             w(0) = 2.0_RP
!!     !
!!         ! Ebenso fuer den zweit-einfachsten Fall
!!         ELSE IF (N.EQ.1) THEN
!!             x(0) = -SQRT( 1.0_RP / 3.0_RP )
!!             w(0) = 1.0_RP
!!             x(1) = -x(0)
!!             w(1) = w(0)
!!     !
!!         ELSE
!!             ! Ansonsten: Symmetrie ausnutzen (nur fuer die erste Haelfte berechnen)
!!             DO j=0,((N+1)/2 - 1)
!!                 ! Anfangsschaetzung mittels Nullstellen der Tschebyschow-Polynome:
!!                 ! Setzte negatives Vorzeichen, um die Stuetzstellen aus dem Intervall (-1,0) zu erhalten.
!!                 x(j) = -cos( (2.0_RP*REAL(j,RP)+1.0_RP) / (2.0_RP*REAL(N,RP)+2.0_RP) * pi )
!!     !
!!                 ! Diese Schaetzung wird nun mithilfe des Newton-Verfahrens praezisiert
!!                 DO k=0,n_it
!!                     ! Dazu wird das (N+1)-ste Legendre-Polynom sowie dessen Ableitung benoetigt
!!                     ! (ausgewertet an der entspr. Stuetzstelle)
!!                     CALL LegendrePolynomialAndDerivative(N+1,x(j),L_N,dL_N)
!!                     ! Newton-Korrektur berechnen und anwenden
!!                     Delta = -L_N/dL_N
!!                     x(j) = x(j) + Delta
!!                     ! Falls vor Abarbeiten aller festgelegten Iterationen des Newton-Verfahrens der berechnete Wert
!!                     ! schon nahe genug an der Nullstelle liegt, wird abgebrochen.
!!                     IF ( ABS(Delta).LE.(tol * ABS(x(j))) ) THEN
!!                         EXIT
!!                     END IF
!!     !
!!                 END DO
!!     !
!!                 CALL LegendrePolynomialAndDerivative(N+1,x(j),L_N,dL_N)
!!                 ! Nutze Symmetrie aus (Multiplikation mit -1)
!!                 x(N-j) = -x(j)
!!                 ! Gewichte berechnen
!!                 w(j) = 2.0_RP / ( (1.0_RP-x(j)*x(j)) * dL_N*dL_N )
!!                 ! Auch die Gewichte sind symmetrisch
!!                 w(N-j) = w(j)
!!     !
!!             END DO
!!     !
!!         END IF
!!     !
!!         ! Falls eine ungerade Anzahl gefordert wird, noch die "mittleren" Werte angeben
!!         IF (MOD(N,2).EQ.0) THEN
!!             CALL LegendrePolynomialAndDerivative(N+1,0.0_RP,L_N,dL_N)
!!             ! Berechnung der Stuetzstellen und Gewichte analog
!!             x(N/2) = 0.0_RP
!!             w(N/2) = 2.0_RP / (dL_N*dL_N)
!!         END IF
!!     !
!!         RETURN
!!     END SUBROUTINE LegendreGaussNodesAndWeights
!! !
!! ! ------------------------------------------------------------------------------------------------------------- !
!! !
!!     SUBROUTINE qAndLEvaluation(N,x,q,dq,L_N)
!!         IMPLICIT NONE
!!         INTEGER, INTENT(IN)         :: N
!!         REAL(KIND=RP), INTENT(IN)   :: x
!!         REAL(KIND=RP), INTENT(OUT)  :: L_N,q,dq
!!     !
!!         ! lokale Variablen
!!         INTEGER                     :: k
!!         REAL(KIND=RP)               :: L_N_1,L_N_2,L_k,dL_N,dL_N_1,dL_N_2,dL_k
!!     !
!!         ! NUR FUER N>=2 !
!!     !
!!         ! Initialisieren
!!         L_N_2 = 1.0_RP
!!         L_N_1 = x
!!         dL_N_2 = 0.0_RP
!!         dL_N_1 = 1.0_RP
!!     !
!!         DO k=2,N
!!             ! Rekursionsformel verwenden
!!             L_N = (2.0_RP*REAL(k,RP)-1.0_RP)/REAL(k,RP) * x * L_N_1 - (REAL(k,RP)-1.0_RP)/REAL(k,RP) * L_N_2
!!             ! Rekursionsformel fuer die Ableitungen verwenden
!!             dL_N = dL_N_2 + (2.0_RP*REAL(k,RP)-1.0_RP) * L_N_1
!!             ! Werte fuer den naechsten Schritt updaten
!!             L_N_2 = L_N_1
!!             L_N_1 = L_N
!!             dL_N_2 = dL_N_1
!!             dL_N_1 = dL_N
!!         END DO
!!     !
!!         ! Einen weiteren Schritt gehen
!!         k = N+1
!!         ! Rekursionsformel verwenden
!!         L_k = (2.0_RP*REAL(k,RP)-1.0_RP)/REAL(k,RP) * x * L_N - (REAL(k,RP)-1.0_RP)/REAL(k,RP) * L_N_2
!!         ! Rekursionsformel fuer die Ableitungen verwenden
!!         dL_k = dL_N_2 + (2.0_RP*REAL(k,RP)-1.0_RP) * L_N_1
!!         ! Benoetigtes Polynom und Ableitung bestimmen
!!         q = L_k - L_N_2
!!         dq = dL_k - dL_N_2
!!     !
!!         RETURN
!!     END SUBROUTINE qAndLEvaluation
!! !
!! ! ------------------------------------------------------------------------------------------------------------- !
!! !
!!     SUBROUTINE LegendreGaussLobattoNodesAndWeights(N,x,w)
!!         IMPLICIT NONE
!!         INTEGER, INTENT(IN)                         :: N
!!         REAL(KIND=RP), DIMENSION(0:N), INTENT(OUT)  :: x,w
!!     !
!!         ! lokale Variablen
!!         INTEGER, PARAMETER            :: n_it = 4
!!         INTEGER                       :: j,k
!!         REAL(KIND=RP), PARAMETER      :: tol = 4.0E-16
!!         REAL(KIND=RP)                 :: q,dq,L_N,Delta
!!
!!         L_N = 0.0
!!     !
!!         ! Fuer den einfachsten Fall Knoten und Gewicht explizit angeben
!!         IF (N.EQ.1) THEN
!!             x(0) = -1.0_RP
!!             w(0) = 1.0_RP
!!             x(1) = 1.0_RP
!!             w(1) = w(0)
!!     !
!!         ELSE
!!             ! Randwerte explizit vorgeben
!!             x(0) = -1.0_RP
!!             w(0) = 2.0_RP / ( REAL(N,RP)*(REAL(N,RP)+1) )
!!             x(N) = 1.0_RP
!!             w(N) = w(0)
!!             ! Ansonsten: Symmetrie ausnutzen (nur fuer die erste Haelfte berechnen)
!!             DO j=1,((N+1)/2 - 1)
!!                 ! Anfangsschaetzung mittels asymptotischer Relation nach Parter:
!!                 ! Setzte negatives Vorzeichen, um die Stuetzstellen aus dem Intervall (-1,0) zu erhalten.
!!                 x(j) = -cos( ((REAL(j,RP)+0.25_RP)*pi)/REAL(N,RP) - (3.0_RP/(8_RP*REAL(N,RP)*pi)) * (1/(REAL(j,RP)+0.25_RP)) )
!!     !
!!                 ! Diese Schaetzung wird nun mithilfe des Newton-Verfahrens praezisiert
!!                 DO k=0,n_it
!!                     ! Dazu wird das (N+1)-ste Polynom sowie dessen Ableitung benoetigt
!!                     ! (ausgewertet an der entspr. Stuetzstelle)
!!                     CALL qAndLEvaluation(N,x(j),q,dq,L_N)
!!                     ! Newton-Korrektur berechnen und anwenden
!!                     Delta = -q/dq
!!                     x(j) = x(j) + Delta
!!                     ! Falls vor Abarbeiten aller festgelegten Iterationen des Newton-Verfahrens der berechnete Wert
!!                     ! schon nahe genug an der Nullstelle liegt, wird abgebrochen.
!!                     IF ( ABS(Delta).LE.(tol * ABS(x(j))) ) THEN
!!                         EXIT
!!                     END IF
!!     !
!!                 END DO
!!     !
!!                 CALL qAndLEvaluation(N,x(j),q,dq,L_N)
!!                 ! Nutze Symmetrie aus (Multiplikation mit -1)
!!                 x(N-j) = -x(j)
!!                 ! Gewichte berechnen
!!                 w(j) = 2.0_RP / ( REAL(N,RP)*(REAL(N,RP)+1.0_RP) * (L_N*L_N) )
!!                 ! Auch die Gewichte sind symmetrisch
!!                 w(N-j) = w(j)
!!     !
!!             END DO
!!     !
!!         END IF
!!     !
!!         ! Falls eine ungerade Anzahl gefordert wird, noch die "mittleren" Werte angeben
!!         IF (MOD(N,2).EQ.0) THEN
!!             CALL qAndLEvaluation(N,0.0_RP,q,dq,L_N)
!!             ! Berechnung der Stuetzstellen und Gewichte analog
!!             x(N/2) = 0.0_RP
!!             w(N/2) = 2.0_RP / ( REAL(N,RP) * (REAL(N,RP)+1.0_RP) * (L_N*L_N) )
!!         END IF
!!     !
!!         RETURN
!!     END SUBROUTINE LegendreGaussLobattoNodesAndWeights
!!
!! subroutine mkLegendreVanderMondeMatrix(n, nodes, Vdm, sVdm)
!!
!!     use linalg_mod, only: invert
!!
!!     integer, intent(in)  :: n
!!     real, intent(in)  :: nodes(:)
!!     real, intent(out) ::   Vdm(:,:)
!!     real, intent(out) ::  sVdm(:,:)
!!     real :: dummy
!!     integer :: i,j
!!
!!     do i = 1,n; do j = 1,n
!!         call LegendrePolynomialAnDderivative(j-1, nodes(i), Vdm(i,j), dummy)
!!     end do; end do
!!
!!     sVdm = invert(Vdm,n)
!!
!! end subroutine

end module


PROGRAM ls
    ! --------------------------------------
    ! Solve linear system of equations AX=B.
    ! --------------------------------------
    !
    ! Results compared with MATLAB(R)
    !
    ! --------------------------------------

    USE LA
    USE OUTPUT

    IMPLICIT NONE

    INTEGER, PARAMETER :: d = 3

    REAL*8, dimension(d,d) :: A
    REAL*8, dimension(d) :: b
    REAL*8, dimension(d) :: x

    A(1,:) = (/1.0D0, 0.0D0, 0.0D0/)
    A(2,:) = (/0.0D0, 2.0D0, 0.0D0/)
    A(3,:) = (/0.0D0, 0.0D0, 3.0D0/)

    b = (/1.0D0,2.0D0,3.0D0/)

    CALL LINEAR_SYSTEM(d,A,b,x)

    CALL print_real_matrix(1,d,x)

    A(1,:) = (/1.0D0, 2.0D0, 3.0D0/)
    A(2,:) = (/-2.0D0, 3.0D0, -5.0D0/)
    A(3,:) = (/0.0D0, 7.0D0, -4.0D0/)

    b = (/-2.0D0,5.0D0,6.0D0/)

    CALL LINEAR_SYSTEM(d,A,b,x)

    CALL print_real_matrix(1,d,x)

    A(1,:) = (/-9.0D0, 2.0D0, 3.0D0/)
    A(2,:) = (/-2.0D0, -3.0D0, -5.0D0/)
    A(3,:) = (/0.0D0, 7.0D0, -4.0D0/)

    b = (/-2.0D0,-4.0D0,6.0D0/)

    CALL LINEAR_SYSTEM(d,A,b,x)

    CALL print_real_matrix(1,d,x)

END PROGRAM ls


! Rectangular waveguide module
! This module contains all the specific calculations
! related to rectangular waveguide
module aloha2d_rectangularwaveguides
  use aloha2d_constants

  implicit none

  contains

  !
  ! Cut-off wavenumber kc of a rectangular waveguide
  !
  function rectwg_kc(a,b,m,n) result(kc)
      real, intent(in)     :: a, b
      integer,intent(in)   :: m, n
      real                 :: kc

      kc = sqrt((m*pi/a)**2 + (n*pi/b)**2);

  end function rectwg_kc

  !
  ! Guided wavenumber beta (kg) of a rectangular waveguide
  !
  function rectwg_beta(f,a,b,m,n) result(beta)
      real, intent(in)     :: f, a, b
      integer,intent(in)   :: m, n
      complex              :: beta

      real :: kc, k0

      ! vacuum wavenumber (evaluated here, in order to avoid using a global parameter)
      k0 = 2*pi*f/c0
      ! Cutoff wavenumber
      kc = rectwg_kc(a,b,m,n)
      ! guided wavenumber
      ! TODO : shall we treat differently the case of complex valued (negative sqrt) ? Or do fortran do the thing correctly ?
      beta = sqrt(one*(k0**2 - kc**2))

  end function rectwg_beta

  !
  ! Complex propagation constant gamma=j*kg
  !
  function rectwg_gamma(f,a,b,m,n)
      real, intent(in)     :: f, a, b
      integer,intent(in)   :: m, n
      complex              :: rectwg_gamma

      real :: kc, k0

      ! vacuum wavenumber (evaluated here, in order to avoid using a global parameter)
      k0 = 2*pi*f/c0
      ! Cutoff wavenumber
      kc = rectwg_kc(a,b,m,n)

      ! guided wavenumber
      ! TODO : shall we treat differently the case of complex valued (negative sqrt) ? Or do fortran do the thing correctly ?
      rectwg_gamma = sqrt(one*(kc**2 - k0**2))

  end function rectwg_gamma

  !
  ! Characteristic Impedance Zc of a rectangular waveguide
  !
  ! NB 22/8/12 : the sign of the real part of the complex square root is important for the .
  !              correct value determination. It seems that the calculation using gamma is better
  !               that the one using beta
  ! TODO ???
  !
  function rectwg_Zc(f,a,b,m,n,mode) result(Zc)
    real, intent(in)     :: f, a, b
    integer,intent(in)   :: m, n
    character(len=1), intent(in)  :: mode
    complex              :: Zc

    complex  :: beta, gamma_mn
    real     :: k0

    ! vacuum wavenumber (evaluated here, in order to avoid using a global parameter)
    k0 = 2*pi*f/c0
    ! guided wavenumber
    beta = rectwg_beta(f,a,b,m,n)

    gamma_mn = rectwg_gamma(f,a,b,m,n)

    select case (mode)

      case ('H')
        print*,'H mode (TE)'
        !Zc = k0*Z0/beta
        Zc = j*k0*Z0/gamma_mn

      case ('E')
        print*,'E mode (TM)'
        !print*,'beta=',rectwg_beta(f,a,b,m,n)
        !print*,'gamma=', rectwg_gamma(f,a,b,m,n)
        !Zc = beta*Z0/k0
        Zc = gamma_mn*Z0/(j*k0)

    end select

  end function rectwg_Zc

  !
  !
  ! Spectral eigenvector function
  !
  subroutine spectralEigenVector(ny, nz, aa, bb, m, n, yy, zz, mode, &
                                 Ey, Ez, Hy, Hz)
    use aloha2d_globalParameters, only : k0
    use aloha2d_plasma_admittance

    implicit none

    real, intent(in) :: nz, ny, aa, bb, yy, zz
    integer, intent(in) :: m, n
    character(len=1), intent(in) :: mode
    complex,intent(out) :: Ey, Ez, Hy, Hz

    real :: coeff_mode_y, coeff_mode_z
    complex :: TF_cos_m, TF_cos_n, TF_sin_m, TF_sin_n

    complex :: YYs_yy, YYs_yz, YYs_zy, YYs_zz, g_S_interp, g_F_interp

    ! Normalization factor
    select case (mode)
      case ('H')
        coeff_mode_y=(n/bb)/SQRT(m**2*bb/aa+n**2*aa/bb)
        coeff_mode_z=-(m/aa)/SQRT(m**2*bb/aa+n**2*aa/bb)

        If (m.GT.0) Then
          coeff_mode_y=coeff_mode_y*SQRT2
          coeff_mode_z=coeff_mode_z*SQRT2
        Endif

        If (n.GT.0) Then
          coeff_mode_y=coeff_mode_y*SQRT2
          coeff_mode_z=coeff_mode_z*SQRT2
        Endif

      case ('E')
        coeff_mode_y=-2.*(m/aa)/SQRT(m**2*bb/aa+n**2*aa/bb)
        coeff_mode_z=-2.*(n/bb)/SQRT(m**2*bb/aa+n**2*aa/bb)

    end select

    ! Fourier transform of the spatial eingenfunction cos and sin
     TF_sin_m = (-m*pi/(aa*k0**2))* &
         (1.-(-1.)**m*exp(-j*k0*ny*aa))* &
         1.0/(ny**2-(m*pi/(k0*aa))**2)* &
         exp(-j*k0*ny*yy)

     TF_cos_m=(-j*ny/k0)*&
         (1.-(-1.)**m*exp(-j*k0*ny*aa))*&
         1/(ny**2-(m*pi/(k0*aa))**2)*&
         exp(-j*k0*ny*yy)

     TF_sin_n=(-n*pi/(bb*k0**2))*&
         (1.-(-1.)**n*exp(-j*k0*nz*bb))*&
         1/(nz**2-(n*pi/(k0*bb))**2)*&
         exp(-j*k0*nz*zz)

     TF_cos_n=(-j*nz/k0)*&
         (1.-(-1.)**n*exp(-j*k0*nz*bb))*&
         1/(nz**2-(n*pi/(k0*bb))**2)*&
         exp(-j*k0*nz*zz)

    ! Spectral compoments
    Hy = -coeff_mode_z*TF_sin_m*TF_cos_n
    Hz = coeff_mode_y*TF_cos_m*TF_sin_n

    Ez = coeff_mode_z*TF_sin_m*TF_cos_n
    Ey = coeff_mode_y*TF_cos_m*TF_sin_n

!    call interpolate_gS_gF(ny, nz, g_S_interp,g_F_interp)
!
!    ! Plasma admittance tensor elements
!    call eval_admittanceTensor(ny, nz, g_S_interp, g_F_interp, &
!                               YYs_yy, YYs_yz, YYs_zy, YYs_zz)
!
!    Hy = Y0*(YYs_yy*Ey + YYs_yz*Ez)
!    Hz = Y0*(YYs_zy*Ey + YYs_zz*Ez)

  end subroutine spectralEigenVector

end module aloha2D_rectangularwaveguides