          program demo_in_margin
          use :: M_verify, only : in_margin
          implicit none
          write(*,*) in_margin(4.00000,3.99999,0.000000001)
          write(*,*) in_margin(4.00000,3.99999,0.00000001)
          write(*,*) in_margin(4.00000,3.99999,0.0000001)
          write(*,*) in_margin(4.00000,3.99999,0.000001)

          write(*,*) in_margin([4.0,40.0,400.0,4000.0,40000.0], [3.9,39.9,399.9,3999.9,39999.9] ,0.000001)
          write(*,*) in_margin([4.0,40.0,400.0,4000.0,40000.0], [3.9,39.9,399.9,3999.9,39999.9] ,0.00001)

          write(*,*) in_margin(4.00000,3.99999,0.00001)
          write(*,*) in_margin(4.00000,3.99999,0.0001)
          write(*,*) in_margin(4.00000,3.99999,0.001)
          write(*,*) in_margin(4.00000,3.99999,0.01)

          end program demo_in_margin


!!
!! Fortran 90 module with program units to do computations for a sphere.
!! It contains a variable declaration, function and subroutine
!!
!! 100212, lb
!!
MODULE sphere

  ! the use statements come before the variable declarations
  USE fourthconst, ONLY : pi ! makes pi available throughout the module
  use precise, only : defaultp

  ! all variable declarations come here (before CONTAINS)
  IMPLICIT NONE
  INTEGER, PARAMETER, PRIVATE :: WP=defaultp

! The following section stores function and subroutines
CONTAINS

  ! Functions appear on the right hand side of the equal sign
  ! V = spherevolume( radius )
  ! A function to calculate the volume of a sphere as function of the
  ! radius r. Note that the function has a type (REAL) and
  ! that the result is stored under the name of the function.
  REAL(wp) FUNCTION spherevolume( r )

    ! The dummy argument r is a real variable
    REAL(wp) :: r

    spherevolume = 4./3.*pi*r**3

    RETURN  ! The return statement is optional here. It means stop
            ! executing this function and return the result to the
            ! calling program unit
  END FUNCTION spherevolume

  !! alternative form (see below for explanation)
  !function spherevolume( r ) result (vol)
  !
  !  real :: r
  !  real :: vol
  !   vol = 4./3.*pi*r**3
  !
  !  return
  !end function spherevolume

  ! In Fortran 90 functions can return more than a standard variable
  ! (real, complex, integer, logical, character, etc.)
  ! The syntax changes a bit. Instead of giving the function itself a
  ! type we declare an additional vaiable of the appropriate type (here
  ! the array p) and put it in paranthesis behind the RESULT key word
  FUNCTION spherept( r, theta, phi) RESULT (p)

    ! declaration of arguments and result
    REAL(wp) :: r, theta, phi   ! radius, latitude and longitude

    ! Two arrays with fixed dimension. Cannot change at runtime
    REAL(wp), DIMENSION(3) :: P  ! (x,y,z)^T
    REAL(wp), DIMENSION(3) :: negnormal

    ! The negative normal vector to a sphere (pointing into the fluid,
    ! i.e. away from the center). Theta in [-pi/2,pi/2], phi in [0,2pi]
    negnormal(1) = 10.*COS(theta)*COS(phi)
    negnormal(2) = COS(theta)*SIN(phi)
    negnormal(3) = SIN(theta)
    ! or
    !negnormal = (/ cos(theta)*cos(phi), cos(theta)*sin(phi), sin(theta)/)

    ! we compute the point. Note that the statement is autmatically
    ! executed for all three dimensions of p
    p = r*negnormal

    RETURN
  END FUNCTION spherept

  ! A subroutine is a program unit that does not return a result under
  ! its own name. They are invoked with the CALL statement
  ! CALL savesphere( ... )
  SUBROUTINE savesphere( filename, comment, isym, &
                         npanels, nfspanels, npoints, deltax, &
                         panels, points, nfsl, nfst, ldx)

     ! As in the program and function, variable declarations come first
     INTEGER :: npoints, npanels, nfspanels
     INTEGER, DIMENSION(2) :: isym
     INTEGER, ALLOCATABLE, DIMENSION(:,:) :: panels

     ! If the string variables are dummy arguments, they can have the
     ! the length * which means they are set to the length of the
     ! actual argument when the subroutine is called.
     CHARACTER(len=*) :: filename  ! file name can be max. 24 char. long
     CHARACTER(len=*) :: comment  !  comment ;-)

     REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: points
     real(wp), allocatable, dimension(:)   :: ldx
     real(wp) ::  deltax

     ! local variables for do-loops
     INTEGER :: i,j

     ! variables free surface map
     INTEGER :: nfsl, nfst

     ! We open the file to store our discretization
     OPEN( 20, file=filename )

     ! write the data in the specific sequence we define
     WRITE(20, '(A)') comment   ! comment
     WRITE(20, '(2I6)') isym(1), isym(2)   ! symmetry flags
     WRITE(20, '(3I6)') npanels, nfspanels, npoints  ! numbers of panels and
                                           !  points
     Write(20, '(1G16.6)') deltax  !  Improvising a deltax colloc shift!
     Write(20, '(1I6)') nfsl
     Write(20, '(1I6)') nfst

     ! now we store the incidence table
     DO i = 1, npanels+nfspanels
        !write(20, '(4I6)') panels(1,i), panels(2,i), panels(3,i), panels(4,i)
        WRITE(20, '(4I6)') (panels(j,i), j=1,4)
     END DO

     ! now we write the point coordinates
     DO i = 1, npoints
        !write(20, '(3G16.6)') points(1,i), points(2,i), points(3,i)
        WRITE(20, '(3G16.6)') (points(j,i), j=1,3)
     END DO

     !write the dx array
     do i=1,nfsl
        WRITE(20, '(1G16.6)') ldx(i)
     end do

     ! don't forget to close the output file
     CLOSE(20)
  END SUBROUTINE savesphere

END MODULE sphere


module test
contains

end module test

program main
    use plantFEM
    use test
    implicit none

    real(real64),parameter :: duration=10.0d0
    integer(int32),parameter :: sampling = 4096
    type(Random_) :: random
    type(IO_) :: f,z
    type(Math_) :: Math
    integer(int32) :: i
    complex(complex64 ),allocatable :: wave(:),spectre(:)
    real(real64),allocatable :: omega(:), t(:)
    real(real64) :: dt,set_omega,set_omega_sub

    set_omega = (100.0d0/2.0d0/math%PI)
    set_omega_sub = (1000.0d0/2.0d0/math%PI)

    print *, "w1= ", set_omega
    print *, "w2= ", set_omega_sub

    create_input_wave: block
        t    = linspace([0.0d0, duration], sampling)
        dt   = duration/dble(sampling)
        wave = zeros(4096)
        do i=1, size(wave)
            wave(i) = random%gauss(mu=0.0d0, sigma=1.0d0)
            wave(i) = sin( set_omega*t(i) )+sin( set_omega_sub*t(i) )+random%gauss(mu=0.0d0, sigma=1.0d0)
        enddo
        wave = taper(wave,margin=0.050d0)
    end block create_input_wave

    show_input_wave: block
        call f%open("input_wave.txt")
        call f%write( t,real(wave) )
        call f%close()
        call f%plot(option="with lines")
    end block show_input_wave

    run_FFT: block
        omega   = linspace([0.0d0, dble(sampling)/duration*2.0d0*math%PI ], sampling)
        spectre = zeros(sampling)
        spectre =  FFT(wave)
        call z%open("spectre.txt")
        do i=1,size(spectre)/2
            call z%write(omega(i),abs( spectre(i)))
        enddo
        call z%close()
        call z%plot(option="with lines",logscale=true)
    end block run_FFT

end program main


MODULE mo_fit

  ! This module contains the numerical recipes routines to fit arbitrary functions to discrete data

  ! Usage:
  !   USE mo_fit, ONLY: fitfun, &                    ! Fit function: wrapper of svdfit & svdvar
  !                     fpoly, fpoly_sp, fpoly_dp, & ! Polynomial base functions
  !                     polyfit, &                   ! Polynomial fitting routine using Lapack
  !                     polyval                      ! Calculates polynomial values for an vectorial input
  !                     svdfit, svdvar               ! fitting routines + errors

  ! Literature
  !   SVDFit
  !       WH Press, SA Teukolsky, WT Vetterling, BP Flannery,
  !           Numerical Recipes in Fortran 90 - The Art of Parallel Scientific Computing, 2nd Edition
  !           Volume 2 of Fortran Numerical Recipes, Cambridge University Press, UK, 1996
  !   Polyfit
  !       http://rosettacode.org/wiki/Polynomial_regression#Fortran

  ! Attention: polyfit uses LAPACK

  ! Written March 2011, Matthias Cuntz - copied and adapted numerical recipes subroutines
  !                                    - fitfun for easy use with mask
  !                                    - linfit Model II: geometric mean regression
  ! Modified Matthias Cuntz, Nov 2011  - sp, dp
  !                                    - documentation
  !          Gregor Schuldt, Sep 2014  - polyval
  !          Matthias Cuntz, Jul 2015  - pgiFortran
  !          Matthias Cuntz, Mai 2016  - rm linfit -> use mo_linfit
  !          Matthias Cuntz, Feb 2020  - make pgiFortran code for all compilers

  ! License
  ! -------
  ! This file is part of the JAMS Fortran package, distributed under the MIT License.
  !
  ! Copyright (c) 2011-2020 Matthias Cuntz - mc (at) macu (dot) de
  !
  ! Permission is hereby granted, free of charge, to any person obtaining a copy
  ! of this software and associated documentation files (the "Software"), to deal
  ! in the Software without restriction, including without limitation the rights
  ! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  ! copies of the Software, and to permit persons to whom the Software is
  ! furnished to do so, subject to the following conditions:
  !
  ! The above copyright notice and this permission notice shall be included in all
  ! copies or substantial portions of the Software.
  !
  ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  ! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  ! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  ! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  ! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  ! SOFTWARE.

  ! Note on Numerical Recipes License
  ! ---------------------------------
  ! Be aware that some code is under the Numerical Recipes License 3rd
  ! edition <http://www.nr.com/aboutNR3license.html>

  ! The Numerical Recipes Personal Single-User License lets you personally
  ! use Numerical Recipes code ("the code") on any number of computers,
  ! but only one computer at a time. You are not permitted to allow anyone
  ! else to access or use the code. You may, under this license, transfer
  ! precompiled, executable applications incorporating the code to other,
  ! unlicensed, persons, providing that (i) the application is
  ! noncommercial (i.e., does not involve the selling or licensing of the
  ! application for a fee), and (ii) the application was first developed,
  ! compiled, and successfully run by you, and (iii) the code is bound
  ! into the application in such a manner that it cannot be accessed as
  ! individual routines and cannot practicably be unbound and used in
  ! other programs. That is, under this license, your application user
  ! must not be able to use Numerical Recipes code as part of a program
  ! library or "mix and match" workbench.

  ! Businesses and organizations that purchase the disk or code download,
  ! and that thus acquire one or more Numerical Recipes Personal
  ! Single-User Licenses, may permanently assign those licenses, in the
  ! number acquired, to individual employees. Such an assignment must be
  ! made before the code is first used and, once made, it is irrevocable
  ! and can not be transferred.

  ! If you do not hold a Numerical Recipes License, this code is only for
  ! informational and educational purposes but cannot be used.

  USE mo_kind, ONLY: i4, sp, dp

  implicit NONE

  PUBLIC :: fitfun  ! Wrapper of svdfit and svdvar
  PUBLIC :: fpoly   ! Routine to fit polynomial with fitfun or svdfit
  PUBLIC :: polyfit ! Fit a polynomial (with Lapack)
  PUBLIC :: polyval ! Calculates polynomial-values for an vectorial input
  PUBLIC :: svdfit  ! Parameter fitting with singular value decomposition
  PUBLIC :: svdvar  ! Variance of fitted parameters with svdfit

  public :: fpoly_sp, fpoly_dp ! individual routines for fpoly to pass to fitting functions

  ! Public interfaces
  ! ------------------------------------------------------------------

  !     NAME
  !         fitfun

  !     PURPOSE
  !         Fits a given function func with the parameters a to the input data by using singular value decomposition.

  !         The function func must give a vector of the base functions for a given x.
  !         For example func for a polynomial should return the vector [1,x,x**2,x**3,x**4,...].

  !         From the numerical recipes documentation for svdfit:
  !         Given a set of N data points x, y with individual standard deviations sig, all arrays of length
  !         N, use chi^2 minimization to determine the M coefficients a of a function that depends linearly
  !         on a, y = sum_i=1^M(a x func_i(x)), with x meaning the dot-product.
  !         Here we solve the fitting equations using singular value decomposition of the NxM matrix, as in paragraph 2.6.
  !         The program returns the M basis functions evaluated at x=X in fit, the M fit parameters a,
  !         their sigma-errors siga, and chi^2 chisq.

  !         If an optinal mask is given, the function is only fit at those locations that correspond to true values in the mask.

  !     CALLING SEQUENCE
  !         call fitfun(xin, yin, sigin, a, func, mask=mask, fit=fit, chisq=chisq, siga=siga)

  !     INTENT(IN)
  !         real(sp/dp) :: xin(:)                1D-array with input x
  !         real(sp/dp) :: yin(:)                1D-array with input y
  !         real(sp/dp) :: sigin(:)              1D-array with input sigma on y
  !         real(sp/dp), dimension(M) :: FUNCTION func(x,n)    Function that outputs the n basis functions

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp/dp), dimension(M) :: a       fitted M parameters

  !     INTENT(IN), OPTIONAL
  !         logical :: mask(:)        1D-array of logical values with size(vec).
  !                                   If present, only those locations in vec corresponding to the true values in mask are used.

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         real(sp/dp), dimension(N) :: fit     Function evaluated at x=X
  !         real(sp/dp), dimension(M) :: siga    Error of fitted parameters
  !         real(sp/dp)               :: chisq   Minimum chi^2

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         ! fit polynomial with degree 5, then detrend original
  !         integer(i4), parameter    :: npt=100, npol=4 ! npol=degrees+1
  !         real(dp), dimension(npt)  :: x, y, sig
  !         real(dp), dimension(npol) :: a
  !         logical,  dimension(npt)  :: maske
  !         maske = .true.
  !         maske(10) = .false.
  !         ! fit
  !         call fitfun(x, y, sig, a, fpoly_dp, fit=fit, mask=maske)
  !         ! detrend
  !         do i=1, npt
  !            y(i) = y(i) - dot_product(a, fpoly(x(i),npol))
  !         end do
  !         ! or
  !         y = y - fit

  !     LITERATURE
  !         Press WH, Teukolsky SA, Vetterling WT, & Flannery BP - Numerical Recipes in Fortran 90 -
  !             The Art of Parallel Scientific Computing, 2nd Edition, Volume 2 of Fortran Numerical Recipes,
  !             Cambridge University Press, UK, 1996

  !     HISTORY
  !         Written, Matthias Cuntz, Mar 2011
  INTERFACE fitfun
     MODULE PROCEDURE fitfun_sp, fitfun_dp
  END INTERFACE fitfun

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

  !     NAME
  !         fpoly

  !     PURPOSE
  !         Fitting routine for a polynomial of degree n-1, i.e. with n coefficients.
  !         Returns vector with [1,x,x**2,x**3,...,x**(n-1)].
  !         To use with fitfun or svdfit.

  !     CALLING SEQUENCE
  !         vec = func(x,n)

  !     INTENT(IN)
  !         real(sp/dp) :: x          x
  !         real(sp/dp) :: n          n-1 powers of x

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp/dp), dimension(n) :: func       vec with [1,x,x**2,x**3,...,x**(n-1)]

  !     INTENT(IN), OPTIONAL
  !         None

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         -> see example at fitfun

  !     LITERATURE
  !         Press WH, Teukolsky SA, Vetterling WT, & Flannery BP - Numerical Recipes in Fortran 90 -
  !             The Art of Parallel Scientific Computing, 2nd Edition, Volume 2 of Fortran Numerical Recipes,
  !             Cambridge University Press, UK, 1996

  !     HISTORY
  !         Written, Matthias Cuntz, Mar 2011
  INTERFACE fpoly
     MODULE PROCEDURE fpoly_sp, fpoly_dp
  END INTERFACE fpoly

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

  !     NAME
  !         polyfit

  !     PURPOSE
  !         Find an approximating polynom of known degree for a given data.

  !         The function polyfit implements least squares approximation of a function
  !         defined in the points as specified by the arrays xi and yi.
  !         The basis dj is xj, j=0,1,..,N. The implementation is straightforward.
  !         First the plane matrix A is created. Aji=dj(xi). Then the linear problem
  !         AATc=Ay is solved. The result cj are the coefficients. Constraint_Error
  !         is propagated when dimensions of X and Y differ or else when the problem is ill-defined.

  !         If an optinal mask is given, the function is only fit at those locations that correspond to true values in the mask.

  !     CALLING SEQUENCE
  !         out = polyfit(x, y, d, mask=mask)

  !     INTENT(IN)
  !         real(sp/dp) :: x(:)                x
  !         real(sp/dp) :: y(:)                y
  !         integer     :: d                   d+1 parameters = polynom of degree d

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp/dp), dimension(d+1) :: polyfit       fitted d+1 parameters for x^0, x^1, ..., x^d

  !     INTENT(IN), OPTIONAL
  !         logical :: mask(:)        1D-array of logical values with size(x)
  !                                   If present, only those locations in vec corresponding to the true values in mask are used.

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         integer, parameter      :: degree = 2
  !         integer                 :: i
  !         real(dp), dimension(11) :: x = (/ (i,i=0,10) /)
  !         real(dp), dimension(11) :: y = (/ 1,   6,  17,  34, 57,  86, 121, 162, 209, 262, 321 /)
  !         real(dp), dimension(degree+1) :: a
  !         a = polyfit(x, y, degree)
  !         write (*, '(F9.4)') a
  !         -> gives 1.0, 2.0, 3.0

  !     LITERATURE
  !         http://rosettacode.org/wiki/Polynomial_regression#Fortran

  !     HISTORY
  !         Written, Matthias Cuntz, Mar 2011
  INTERFACE polyfit
     MODULE PROCEDURE polyfit_sp, polyfit_dp
  END INTERFACE polyfit

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

  !     NAME
  !         polyval

  !     PURPOSE
  !         Evaluates a polynomial for a given vector.

  !         Input 'poly' must be an array containing the values for the coefficients of the polynomial.
  !         For example 'poly' for the polynomial "1 + 2 * x + 3 * x**2" should be (/ 1, 2, 3 /)

  !         Input 'xwert' can be scalar or 1D-array with values for which the user wants to evaluate the given polynomial.

  !     CALLING SEQUENCE
  !         vec = polyval(poly,xwert)

  !     INTENT(IN)
  !         real(sp/dp), dimension(:)   ::   poly                   polynomial-coefficients
  !         real(sp/dp)[, dimension(:)] ::   xwert                  Evaluation-value(s)

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp/dp)[, dimension(size(xwert,1))] :: polyval        (vec with) polynomial-value(s) at xwert

  !     INTENT(IN), OPTIONAL
  !         None

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         For the polynom  "1 + 2 * x + 3 * x**2" and the values 1 and 2
  !         poly  = (/ 1, 2, 3/)
  !         xwert = (/ 1, 2 /)
  !         Erg   = polyval(poly,xwert)
  !         ----> Erg = (/ 6, 17 /)

  !     LITERATURE
  !

  !     HISTORY
  !         Written, Gregor Schuldt, Sep 2014

  INTERFACE polyval
     MODULE PROCEDURE polyval_0d_sp, polyval_1d_sp, polyval_0d_dp, polyval_1d_dp
  END INTERFACE polyval

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

  !     NAME
  !         svdfit

  !     PURPOSE
  !         Fits a given function func with the parameters a to the input data by using singular value decomposition.

  !         The function func must give a vector of the base functions for a given x.
  !         For example func for a polynomial should return the vector [1,x,x**2,x**3,x**4,...].

  !         From the numerical recipes documentation:
  !         Given a set of datapoints x(1:ndata), y(1:ndata) with individual standard deviations
  !         sig(1:ndata), use chi2 minimization to determine the ma coefficients a of the fitting function
  !         y=sum(ai*afunci(x))). Here we solve the fitting equations using singular value decomposition
  !         of the n data by ma matrix, as in paragraph 2.6. Arrays u(1:mp,1:np), v(1:np,1:np),
  !         w(1:np) provide workspace on input; on output they define the singular value decomposition,
  !         and can be used to obtain the covariance matrix. mp,np are the physical dimensions
  !         of the matrices u,v,w, as indicated above. It is necessary that mp>=ndata, np>=ma. The
  !         program returns values for the ma fit parameters a, and chi2, chisq. The user supplies a
  !         subroutine funcs(x,afunc,ma) that returns them a basis functions evaluated at x=x
  !         in the array afunc.

  !     CALLING SEQUENCE
  !         call svdfit(x, y, sig, a, v, w, chisq, func)

  !     INTENT(IN)
  !         real(sp/dp) :: x(:)                1D-array with input x
  !         real(sp/dp) :: y(:)                1D-array with input y
  !         real(sp/dp) :: sig(:)              1D-array with input sigma on y
  !         real(sp/dp), dimension(M) :: FUNCTION func(x,n)    Function that outputs the n basis functions

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp/dp), dimension(M)   :: a       fitted M parameters
  !         real(sp/dp)                 :: chisq   Minimum chi^2
  !         real(sp/dp), dimension(M,M) :: v       output for svdvar
  !         real(sp/dp), dimension(M)   :: w       output for svdvar

  !     INTENT(IN), OPTIONAL
  !         None

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         ! fit polynomial with degree 5
  !         integer(i4b), parameter :: npt=100, npol=5
  !         integer(i4b) :: i
  !         real(dp) :: chisq
  !         real(dp), dimension(npol)      :: a, w
  !         real(dp), dimension(npt)       :: x, y, sig
  !         real(dp), dimension(npol,npol) :: cvm, v
  !         call svdfit(x, y, sig, a, v, w, chisq, fpoly_dp)
  !         call svdvar(v, w, cvm)
  !         do i=1, npol
  !            write(*,'(1x,f12.6,a,f10.6)') a(i), '  +-', sqrt(cvm(i,i))
  !         end do

  !     LITERATURE
  !         Press WH, Teukolsky SA, Vetterling WT, & Flannery BP - Numerical Recipes in Fortran 90 -
  !             The Art of Parallel Scientific Computing, 2nd Edition, Volume 2 of Fortran Numerical Recipes,
  !             Cambridge University Press, UK, 1996

  !     HISTORY
  !         Written, Matthias Cuntz, Mar 2011
  INTERFACE svdfit
     MODULE PROCEDURE svdfit_sp, svdfit_dp
  END INTERFACE svdfit

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

  !     NAME
  !         svdvar

  !     PURPOSE
  !         Calculates the variance/covariance for the singular value decomposition estimates.

  !         From the numerical recipes documentation:
  !         To evaluate the covariance matrix cvm of the fit for ma parameters obtained by svdfit,
  !         call this routine with matrices v,w as returned from svdfit. np,ncvm give the physical
  !         dimensions of v,w,cvm as indicated.

  !     CALLING SEQUENCE
  !         call svdvar(v, w, cvm)

  !     INTENT(IN)
  !         real(sp/dp), dimension(M,M) :: v       output from svdfit
  !         real(sp/dp), dimension(M)   :: w       output from svdfit

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp/dp), dimension(M,M)   :: cvm     covariance matrix for M fitted parameters

  !     INTENT(IN), OPTIONAL
  !         None

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         ! fit polynomial with degree 5
  !         integer(i4b), parameter :: npt=100, npol=5
  !         integer(i4b) :: i
  !         real(dp) :: chisq
  !         real(dp), dimension(npol)      :: a, w
  !         real(dp), dimension(npt)       :: x, y, sig
  !         real(dp), dimension(npol,npol) :: cvm, v
  !         call svdfit(x, y, sig, a, v, w, chisq, fpoly_dp)
  !         call svdvar(v, w, cvm)
  !         do i=1, npol
  !            write(*,'(1x,f12.6,a,f10.6)') a(i), '  +-', sqrt(cvm(i,i))
  !         end do

  !     LITERATURE
  !         Press WH, Teukolsky SA, Vetterling WT, & Flannery BP - Numerical Recipes in Fortran 90 -
  !             The Art of Parallel Scientific Computing, 2nd Edition, Volume 2 of Fortran Numerical Recipes,
  !             Cambridge University Press, UK, 1996

  !     HISTORY
  !         Written, Matthias Cuntz, Mar 2011
  INTERFACE svdvar
     MODULE PROCEDURE svdvar_sp, svdvar_dp
  END INTERFACE svdvar

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

  PRIVATE

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

  ! Private interfaces, mostly from numerical recipes
  INTERFACE geop
     MODULE PROCEDURE geop_dp, geop_i4, geop_sp, geop_v_dp, geop_v_sp
  END INTERFACE geop
  INTERFACE outerprod
     MODULE PROCEDURE outerprod_dp, outerprod_sp
  END INTERFACE outerprod
  INTERFACE pythag
     MODULE PROCEDURE pythag_dp, pythag_sp
  END INTERFACE pythag
  INTERFACE svdksb
     MODULE PROCEDURE svdksb_dp, svdksb_sp
  END INTERFACE svdksb
  INTERFACE svdcmp
     MODULE PROCEDURE svdcmp_dp, svdcmp_sp
  END INTERFACE svdcmp
  INTERFACE vabs
     MODULE PROCEDURE vabs_dp, vabs_sp
  END INTERFACE vabs

  ! for geop
  INTEGER(i4), PARAMETER :: NPAR_GEOP=4, NPAR2_GEOP=2

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

CONTAINS

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

  SUBROUTINE fitfun_dp(xin, yin, sigin, a, func, mask, fit, chisq, siga)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:), INTENT(IN)  :: xin
    REAL(dp), DIMENSION(:), INTENT(IN)  :: yin
    REAL(dp), DIMENSION(:), INTENT(IN)  :: sigin
    REAL(dp), DIMENSION(:), INTENT(OUT) :: a
    INTERFACE
       FUNCTION func(x,n)
         USE mo_kind, ONLY: i4, dp
         IMPLICIT NONE
         REAL(dp),    INTENT(IN)   :: x
         INTEGER(i4), INTENT(IN)   :: n
         REAL(dp),    DIMENSION(n) :: func
       END FUNCTION func
    END INTERFACE
    LOGICAL,  DIMENSION(:),         OPTIONAL, INTENT(IN)  :: mask
    REAL(dp), DIMENSION(size(xin)), OPTIONAL, INTENT(OUT) :: fit
    REAL(dp),                       OPTIONAL, INTENT(OUT) :: chisq
    REAL(dp), DIMENSION(size(a)),   OPTIONAL, INTENT(OUT) :: siga

    LOGICAL,  DIMENSION(size(xin))       :: maske
    REAL(dp), DIMENSION(size(a))         :: w
    REAL(dp), DIMENSION(size(a),size(a)) :: cvm, v
    REAL(dp), DIMENSION(:), ALLOCATABLE  :: x, y, sig
    REAL(dp), DIMENSION(:), ALLOCATABLE  :: out
    REAL(dp) :: ichisq
    INTEGER :: i, nmask, na

    if (size(xin) /= size(yin))   stop 'Error fitfun_dp: size(x) /= size(y)'
    if (size(sigin) /= size(yin)) stop 'Error fitfun_dp: size(sig) /= size(y)'
    maske(:) = .true.
    if (present(mask)) then
       if (size(mask) /= size(xin)) stop 'Error fitfun_dp: size(mask) /= size(x)'
       maske = mask
    endif
    nmask = count(maske)
    allocate(x(nmask))
    allocate(y(nmask))
    allocate(sig(nmask))
    x(1:nmask)   = pack(xin,maske)
    y(1:nmask)   = pack(yin,maske)
    sig(1:nmask) = pack(sigin,maske)

    call svdfit(x, y, sig, a, v, w, ichisq, func)

    if (present(chisq)) chisq = ichisq
    na = size(a)
    if (present(siga)) then
       call svdvar(v, w, cvm)
       do i=1, na
          siga(i) = sqrt(cvm(i,i))
       end do
    end if
    if (present(fit)) then
       allocate(out(nmask))
       do i=1, nmask
          out(i) = dot_product(a, real(func(real(x(i),dp),na),dp))
       end do
       fit = unpack(out,maske,0.0_dp)
       deallocate(out)
    endif

    deallocate(x)
    deallocate(y)
    deallocate(sig)

  END SUBROUTINE fitfun_dp

  SUBROUTINE fitfun_sp(xin, yin, sigin, a, func, mask, fit, chisq, siga)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:), INTENT(IN)  :: xin
    REAL(sp), DIMENSION(:), INTENT(IN)  :: yin
    REAL(sp), DIMENSION(:), INTENT(IN)  :: sigin
    REAL(sp), DIMENSION(:), INTENT(OUT) :: a
    INTERFACE
       FUNCTION func(x,n)
         USE mo_kind, ONLY: i4, sp
         IMPLICIT NONE
         REAL(sp),    INTENT(IN)   :: x
         INTEGER(i4), INTENT(IN)   :: n
         REAL(sp),    DIMENSION(n) :: func
       END FUNCTION func
    END INTERFACE
    LOGICAL,  DIMENSION(:),         OPTIONAL, INTENT(IN)  :: mask
    REAL(sp), DIMENSION(size(xin)), OPTIONAL, INTENT(OUT) :: fit
    REAL(sp),                       OPTIONAL, INTENT(OUT) :: chisq
    REAL(sp), DIMENSION(size(a)),   OPTIONAL, INTENT(OUT) :: siga

    LOGICAL,  DIMENSION(size(xin))       :: maske
    REAL(sp), DIMENSION(size(a))         :: w
    REAL(sp), DIMENSION(size(a),size(a)) :: cvm, v
    REAL(sp), DIMENSION(:), ALLOCATABLE  :: x, y, sig
    REAL(sp), DIMENSION(:), ALLOCATABLE  :: out
    REAL(sp) :: ichisq
    INTEGER :: i, nmask, na

    if (size(xin) /= size(yin))   stop 'Error fitfun_sp: size(x) /= size(y)'
    if (size(sigin) /= size(yin)) stop 'Error fitfun_sp: size(sig) /= size(y)'
    maske(:) = .true.
    if (present(mask)) then
       if (size(mask) /= size(xin)) stop 'Error fitfun_sp: size(mask) /= size(x)'
       maske = mask
    endif
    nmask = count(maske)
    allocate(x(nmask))
    allocate(y(nmask))
    allocate(sig(nmask))
    x(1:nmask)   = pack(xin,maske)
    y(1:nmask)   = pack(yin,maske)
    sig(1:nmask) = pack(sigin,maske)

    call svdfit(x, y, sig, a, v, w, ichisq, func)

    if (present(chisq)) chisq = ichisq
    na = size(a)
    if (present(siga)) then
       call svdvar(v, w, cvm)
       do i=1, na
          siga(i) = sqrt(cvm(i,i))
       end do
    end if
    if (present(fit)) then
       allocate(out(nmask))
       do i=1, nmask
          out(i) = dot_product(a, real(func(real(x(i),sp),na),sp))
       end do
       fit = unpack(out,maske,0.0_sp)
       deallocate(out)
    endif

    deallocate(x)
    deallocate(y)
    deallocate(sig)

  END SUBROUTINE fitfun_sp

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

  FUNCTION fpoly_dp(x,n)

    IMPLICIT NONE

    REAL(dp),    INTENT(IN)   :: x
    INTEGER(i4), INTENT(IN)   :: n
    REAL(dp),    DIMENSION(n) :: fpoly_dp

    fpoly_dp = geop(1.0_dp,x,n)

  END FUNCTION fpoly_dp

  FUNCTION fpoly_sp(x,n)

    IMPLICIT NONE

    REAL(sp),    INTENT(IN)   :: x
    INTEGER(i4), INTENT(IN)   :: n
    REAL(sp),    DIMENSION(n) :: fpoly_sp

    fpoly_sp = geop(1.0_sp,x,n)

  END FUNCTION fpoly_sp

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

  ! From numerical recipes documentation
  ! Returns an array of length n containing a geometric progression whose first
  ! value is first and whose multiplier is factor. If first and factor
  ! have rank greater than zero, returns an array of one larger rank, with the
  ! last subscript having size n and indexing the progression.
  FUNCTION geop_dp(first,factor,n)

    REAL(dp),    INTENT(IN)   :: first,factor
    INTEGER(i4), INTENT(IN)   :: n
    REAL(dp),    DIMENSION(n) :: geop_dp

    INTEGER(i4) :: k,k2
    REAL(dp)     :: temp

    if (n > 0) geop_dp(1)=first
    if (n <= NPAR_GEOP) then
       do k=2,n
          geop_dp(k)=geop_dp(k-1)*factor
       end do
    else
       do k=2,NPAR2_GEOP
          geop_dp(k)=geop_dp(k-1)*factor
       end do
       temp=factor**NPAR2_GEOP
       k=NPAR2_GEOP
       do
          if (k >= n) exit
          k2=k+k
          geop_dp(k+1:min(k2,n))=temp*geop_dp(1:min(k,n-k))
          temp=temp*temp
          k=k2
       end do
    end if

  END FUNCTION geop_dp

  FUNCTION geop_i4(first,factor,n)

    INTEGER(i4), INTENT(IN)   :: first, factor, n
    INTEGER(i4), DIMENSION(n) :: geop_i4

    INTEGER(i4) :: k, k2, temp

    if (n > 0) geop_i4(1)=first
    if (n <= NPAR_GEOP) then
       do k=2,n
          geop_i4(k)=geop_i4(k-1)*factor
       end do
    else
       do k=2,NPAR2_GEOP
          geop_i4(k)=geop_i4(k-1)*factor
       end do
       temp=factor**NPAR2_GEOP
       k=NPAR2_GEOP
       do
          if (k >= n) exit
          k2=k+k
          geop_i4(k+1:min(k2,n))=temp*geop_i4(1:min(k,n-k))
          temp=temp*temp
          k=k2
       end do
    end if

  END FUNCTION geop_i4

  FUNCTION geop_sp(first,factor,n)

    REAL(sp),    INTENT(IN)   :: first,factor
    INTEGER(i4), INTENT(IN)   :: n
    REAL(sp),    DIMENSION(n) :: geop_sp

    INTEGER(i4) :: k,k2
    REAL(sp)     :: temp

    if (n > 0) geop_sp(1)=first
    if (n <= NPAR_GEOP) then
       do k=2,n
          geop_sp(k)=geop_sp(k-1)*factor
       end do
    else
       do k=2,NPAR2_GEOP
          geop_sp(k)=geop_sp(k-1)*factor
       end do
       temp=factor**NPAR2_GEOP
       k=NPAR2_GEOP
       do
          if (k >= n) exit
          k2=k+k
          geop_sp(k+1:min(k2,n))=temp*geop_sp(1:min(k,n-k))
          temp=temp*temp
          k=k2
       end do
    end if

  END FUNCTION geop_sp

  FUNCTION geop_v_dp(first,factor,n)

    REAL(dp),     DIMENSION(:), INTENT(IN) :: first, factor
    INTEGER(i4),               INTENT(IN) :: n
    REAL(dp),     DIMENSION(size(first),n) :: geop_v_dp

    INTEGER(i4) :: k,k2
    REAL(dp), DIMENSION(size(first)) :: temp

    if (n > 0) geop_v_dp(:,1)=first(:)
    if (n <= NPAR_GEOP) then
       do k=2,n
          geop_v_dp(:,k)=geop_v_dp(:,k-1)*factor(:)
       end do
    else
       do k=2,NPAR2_GEOP
          geop_v_dp(:,k)=geop_v_dp(:,k-1)*factor(:)
       end do
       temp=factor**NPAR2_GEOP
       k=NPAR2_GEOP
       do
          if (k >= n) exit
          k2=k+k
          geop_v_dp(:,k+1:min(k2,n))=geop_v_dp(:,1:min(k,n-k))*&
               spread(temp,2,size(geop_v_dp(:,1:min(k,n-k)),2))
          temp=temp*temp
          k=k2
       end do
    end if

  END FUNCTION geop_v_dp

  FUNCTION geop_v_sp(first,factor,n)

    REAL(sp),     DIMENSION(:), INTENT(IN) :: first, factor
    INTEGER(i4),               INTENT(IN) :: n
    REAL(sp),     DIMENSION(size(first),n) :: geop_v_sp

    INTEGER(i4) :: k,k2
    REAL(sp), DIMENSION(size(first)) :: temp

    if (n > 0) geop_v_sp(:,1)=first(:)
    if (n <= NPAR_GEOP) then
       do k=2,n
          geop_v_sp(:,k)=geop_v_sp(:,k-1)*factor(:)
       end do
    else
       do k=2,NPAR2_GEOP
          geop_v_sp(:,k)=geop_v_sp(:,k-1)*factor(:)
       end do
       temp=factor**NPAR2_GEOP
       k=NPAR2_GEOP
       do
          if (k >= n) exit
          k2=k+k
          geop_v_sp(:,k+1:min(k2,n))=geop_v_sp(:,1:min(k,n-k))*&
               spread(temp,2,size(geop_v_sp(:,1:min(k,n-k)),2))
          temp=temp*temp
          k=k2
       end do
    end if

  END FUNCTION geop_v_sp

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

  ! From numerical recipes documentation
  ! Returns a matrix that is the outer product of two vectors.
  ! a*b with size(a)/=size(b)
  FUNCTION outerprod_dp(a,b)

    REAL(dp), DIMENSION(:), INTENT(IN)   :: a, b
    REAL(dp), DIMENSION(size(a),size(b)) :: outerprod_dp

    outerprod_dp = spread(a,dim=2,ncopies=size(b)) * &
         spread(b,dim=1,ncopies=size(a))

  END FUNCTION outerprod_dp

  FUNCTION outerprod_sp(a,b)

    REAL(sp), DIMENSION(:), INTENT(IN)   :: a, b
    REAL(sp), DIMENSION(size(a),size(b)) :: outerprod_sp

    outerprod_sp = spread(a,dim=2,ncopies=size(b)) * &
         spread(b,dim=1,ncopies=size(a))

  END FUNCTION outerprod_sp

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

  ! sqrt(a**2+b**2)
  FUNCTION pythag_dp(a,b)

    IMPLICIT NONE

    REAL(dp), INTENT(IN) :: a,b
    REAL(dp)             :: pythag_dp

    REAL(dp) :: absa, absb

    absa = abs(a)
    absb = abs(b)
    if (absa > absb) then
       pythag_dp = absa*sqrt(1.0_dp+(absb/absa)**2)
    else
       if (absb < tiny(1.0_dp)) then
          pythag_dp = 0.0_dp
       else
          pythag_dp = absb*sqrt(1.0_dp+(absa/absb)**2)
       end if
    end if

  END FUNCTION pythag_dp

  FUNCTION pythag_sp(a,b)

    IMPLICIT NONE

    REAL(sp), INTENT(IN) :: a,b
    REAL(sp)             :: pythag_sp

    REAL(sp) :: absa, absb

    absa = abs(a)
    absb = abs(b)
    if (absa > absb) then
       pythag_sp = absa*sqrt(1.0_sp+(absb/absa)**2)
    else
       if (absb < tiny(1.0_sp)) then
          pythag_sp = 0.0_sp
       else
          pythag_sp = absb*sqrt(1.0_sp+(absa/absb)**2)
       end if
    end if

  END FUNCTION pythag_sp

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

  FUNCTION polyfit_dp(vxin, vyin, d, mask)

    IMPLICIT NONE

    real(dp), dimension(:), intent(in)    :: vxin, vyin
    integer,                intent(in)    :: d
    LOGICAL,  DIMENSION(:), OPTIONAL, INTENT(IN) :: mask
    real(dp), dimension(d+1)              :: polyfit_dp

    real(dp), dimension(:,:), allocatable :: X
    real(dp), dimension(:,:), allocatable :: XT
    real(dp), dimension(:,:), allocatable :: XTX
    integer :: i
    integer :: n, lda, lwork
    integer :: info
    integer, dimension(:), allocatable :: ipiv
    real(dp), dimension(:), allocatable :: work
    real(dp), dimension(:), allocatable :: vx, vy
    LOGICAL,   DIMENSION(size(vxin)) :: maske
    integer :: nmask

    EXTERNAL :: DGETRF, DGETRI

    maske(:) = .true.
    if (present(mask)) then
       if (size(mask) /= size(vxin)) stop 'Error polyfit_dp: size(mask) /= size(vxin)'
       maske = mask
    endif
    nmask = count(maske)
    allocate(vx(nmask))
    allocate(vy(nmask))
    vx(1:nmask) = pack(vxin,maske)
    vy(1:nmask) = pack(vyin,maske)

    n     = d+1
    lda   = n
    lwork = n
    allocate(ipiv(n))
    allocate(work(lwork))
    allocate(XT(n,size(vx)))
    allocate(X(size(vx),n))
    allocate(XTX(n,n))

    ! prepare the matrix
    X(1:nmask,1) = 1.0_dp
    if (n > 1) X(1:nmask,2) = vx
    do i=3, n
       X(1:nmask,i) = vx(1:nmask)**(i-1)
    end do

    XT  = transpose(X)
    XTX = matmul(XT,X)

    ! calls to LAPACK subs DGETRF and DGETRI
    call DGETRF(n, n, XTX, lda, ipiv, info)
    if ( info /= 0 ) stop 'Problem polyfit_dp 1'
    call DGETRI(n, XTX, lda, ipiv, work, lwork, info)
    if ( info /= 0 ) stop 'Problem polyfit_dp 2'

    polyfit_dp = matmul(matmul(XTX,XT), vy)

    deallocate(ipiv)
    deallocate(work)
    deallocate(X)
    deallocate(XT)
    deallocate(XTX)

  END FUNCTION polyfit_dp

  FUNCTION polyfit_sp(vxin, vyin, d, mask)

    IMPLICIT NONE

    real(sp), dimension(:), intent(in)    :: vxin, vyin
    integer,                intent(in)    :: d
    LOGICAL,  DIMENSION(:), OPTIONAL, INTENT(IN) :: mask
    real(sp), dimension(d+1)              :: polyfit_sp

    real(sp), dimension(:,:), allocatable :: X
    real(sp), dimension(:,:), allocatable :: XT
    real(sp), dimension(:,:), allocatable :: XTX
    integer :: i
    integer :: n, lda, lwork
    integer :: info
    integer, dimension(:), allocatable :: ipiv
    real(sp), dimension(:), allocatable :: work
    real(sp), dimension(:), allocatable :: vx, vy
    LOGICAL,   DIMENSION(size(vxin)) :: maske
    integer :: nmask

    EXTERNAL :: SGETRF, SGETRI

    maske(:) = .true.
    if (present(mask)) then
       if (size(mask) /= size(vxin)) stop 'Error polyfit_sp: size(mask) /= size(vxin)'
       maske = mask
    endif
    nmask = count(maske)
    allocate(vx(nmask))
    allocate(vy(nmask))
    vx(1:nmask) = pack(vxin,maske)
    vy(1:nmask) = pack(vyin,maske)

    n     = d+1
    lda   = n
    lwork = n
    allocate(ipiv(n))
    allocate(work(lwork))
    allocate(XT(n,size(vx)))
    allocate(X(size(vx),n))
    allocate(XTX(n,n))

    ! prepare the matrix
    X(1:nmask,1) = 1.0_sp
    if (n > 1) X(1:nmask,2) = vx
    do i=3, n
       X(1:nmask,i) = vx(1:nmask)**(i-1)
    end do

    XT  = transpose(X)
    XTX = matmul(XT,X)

    ! calls to LAPACK subs SGETRF and SGETRI
    call SGETRF(n, n, XTX, lda, ipiv, info)
    if ( info /= 0 ) stop 'Problem polyfit_sp 1'
    call SGETRI(n, XTX, lda, ipiv, work, lwork, info)
    if ( info /= 0 ) stop 'Problem polyfit_sp 2'

    polyfit_sp = matmul(matmul(XTX,XT), vy)

    deallocate(ipiv)
    deallocate(work)
    deallocate(X)
    deallocate(XT)
    deallocate(XTX)

  END FUNCTION polyfit_sp

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

  function polyval_0d_sp(poly, xwert)

    implicit none

    real(sp),              dimension(:),       INTENT(IN) :: poly
    real(sp),                                  INTENT(IN) :: xwert
    real(sp)                                              :: polyval_0d_sp

    integer(i4)                                           :: mm

    mm = size(poly, 1)
    polyval_0d_sp = dot_product( poly , fpoly(xwert, mm))

  end function polyval_0d_sp

  function polyval_0d_dp(poly, xwert)

    implicit none

    real(dp),              dimension(:),       INTENT(IN) :: poly
    real(dp),                                  INTENT(IN) :: xwert
    real(dp)                                              :: polyval_0d_dp

    integer(i4)                                           ::  mm

    mm = size(poly, 1)
    polyval_0d_dp = dot_product( poly , fpoly(xwert, mm))

  end function polyval_0d_dp

 function polyval_1d_sp(poly, xwert)

    implicit none

    real(sp),              dimension(:),       INTENT(IN) :: poly
    real(sp),              dimension(:),       INTENT(IN) :: xwert
    real(sp),              dimension(size(xwert,1))       :: polyval_1d_sp

    integer(i4)                                           :: ii, nn, mm

    mm = size(poly,1)
    nn = size(xwert,1)
    do ii = 1, nn
       polyval_1d_sp(ii) = dot_product( poly , fpoly(xwert(ii), mm))
    end do

  end function polyval_1d_sp

 function polyval_1d_dp(poly, xwert)

    implicit none

    real(dp),              dimension(:),       INTENT(IN) :: poly
    real(dp),              dimension(:),       INTENT(IN) :: xwert
    real(dp),              dimension(size(xwert,1))       :: polyval_1d_dp

    integer(i4)                                           :: ii, nn, mm

    mm = size(poly,1)
    nn = size(xwert,1)
    do ii = 1, nn
       polyval_1d_dp(ii) = dot_product( poly , fpoly(xwert(ii), mm))
    end do

  end function polyval_1d_dp

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

  ! From Numerical Recipes in F77 book
  ! Solves A*X=B for a vector X, where A is specified by the arrays u, w, v as returned by
  ! svdcmp. m and n are the logical dimensions of a, and will be equal for square matrices. mp
  ! and np are the physical dimensions of a. b(1:m) is the input right-handside. x(1:n) is
  ! the output solution vector. No input quantities are destroyed, so the routine may be called
  ! sequentially with different bs.
  SUBROUTINE svdksb_dp(u,w,v,b,x)

    REAL(dp), DIMENSION(:,:), INTENT(IN) :: u,v
    REAL(dp), DIMENSION(:), INTENT(IN) :: w,b
    REAL(dp), DIMENSION(:), INTENT(OUT) :: x
    !INTEGER(i4) :: ndum, mdum
    REAL(dp), DIMENSION(size(x)) :: tmp
    REAL(dp), DIMENSION(size(w)) :: wtmp

    if (size(u,1) /= size(b))   stop 'svdksb_dp: size(u,1) /= size(b)'
    if (size(u,2) /= size(v,1)) stop 'svdksb_dp: size(u,2) /= size(v,1)'
    if (size(u,2) /= size(v,2)) stop 'svdksb_dp: size(u,2) /= size(v,2)'
    if (size(u,2) /= size(w))   stop 'svdksb_dp: size(u,2) /= size(w)'
    if (size(u,2) /= size(x))   stop 'svdksb_dp: size(u,2) /= size(x)'
    !mdum = size(u,1)
    !ndum = size(u,2)
    wtmp = w
    where (abs(w) < tiny(1.0_dp)) wtmp = 1.0_dp
    tmp = matmul(b,u) / wtmp
    where (abs(w) < tiny(1.0_dp)) tmp = 0.0_dp
    x = matmul(v,tmp)

  END SUBROUTINE svdksb_dp

  SUBROUTINE svdksb_sp(u,w,v,b,x)

    REAL(sp), DIMENSION(:,:), INTENT(IN) :: u,v
    REAL(sp), DIMENSION(:), INTENT(IN) :: w,b
    REAL(sp), DIMENSION(:), INTENT(OUT) :: x
    !INTEGER(i4) :: ndum, mdum
    REAL(sp), DIMENSION(size(x)) :: tmp
    REAL(sp), DIMENSION(size(w)) :: wtmp

    if (size(u,1) /= size(b))   stop 'svdksb_sp: size(u,1) /= size(b)'
    if (size(u,2) /= size(v,1)) stop 'svdksb_sp: size(u,2) /= size(v,1)'
    if (size(u,2) /= size(v,2)) stop 'svdksb_sp: size(u,2) /= size(v,2)'
    if (size(u,2) /= size(w))   stop 'svdksb_sp: size(u,2) /= size(w)'
    if (size(u,2) /= size(x))   stop 'svdksb_sp: size(u,2) /= size(x)'
    !mdum = size(u,1)
    !ndum = size(u,2)
    wtmp = w
    where (abs(w) < tiny(1.0_sp)) wtmp = 1.0_sp
    tmp = matmul(b,u) / wtmp
    where (abs(w) < tiny(1.0_sp)) tmp = 0.0_sp
    x = matmul(v,tmp)

  END SUBROUTINE svdksb_sp

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

  ! From Numerical Recipes in F77 book
  ! Given a matrix a(1:m,1:n), with physical dimensions mp by np, this routine computes its
  ! singular value decomposition, A=U*W*VT. The matrix U replaces a on output. The
  ! diagonal matrix of singular values W is output as a vector w(1:n). The matrix V (not the
  ! transpose VT) is output as v(1:n,1:n).
  SUBROUTINE svdcmp_dp(a,w,v)

    use mo_utils, only: eq

    IMPLICIT NONE

    REAL(dp), DIMENSION(:,:), INTENT(INOUT) :: a
    REAL(dp), DIMENSION(:),   INTENT(OUT)   :: w
    REAL(dp), DIMENSION(:,:), INTENT(OUT)   :: v

    INTEGER(i4) :: i, its, j, k, l, m, n, nm
    REAL(dp)    :: c, f, g, h, s, scale, x, y, z, anorm
    REAL(dp), DIMENSION(size(a,1)) :: tempm
    REAL(dp), DIMENSION(size(a,2)) :: rv1, tempn

    m = size(a,1)
    if (size(a,2) /= size(v,1)) stop 'Error svdcmp_dp: size(a,2) /= size(v,1)'
    if (size(a,2) /= size(v,2)) stop 'Error svdcmp_dp: size(a,2) /= size(v,2)'
    if (size(a,2) /= size(w))   stop 'Error svdcmp_dp: size(a,2) /= size(w)'
    n = size(a,2)
    g     = 0.0_dp
    scale = 0.0_dp
    do i=1, n
       l = i+1
       rv1(i) = scale*g
       g     = 0.0_dp
       scale = 0.0_dp
       if (i <= m) then
          scale = sum(abs(a(i:m,i)))
          if (abs(scale) > 0.0_dp) then
             a(i:m,i) = a(i:m,i)/scale
             s = dot_product(a(i:m,i),a(i:m,i))
             f = a(i,i)
             g = -sign(sqrt(s),f)
             h = f*g-s
             a(i,i) = f-g
             tempn(l:n) = matmul(a(i:m,i),a(i:m,l:n))/h
             if (l <= n) & ! pgfortran out-of-bounds in debug mode
                  a(i:m,l:n) = a(i:m,l:n)+outerprod(a(i:m,i),tempn(l:n))
             a(i:m,i)   = scale*a(i:m,i)
          end if
       end if
       w(i) = scale*g
       g     = 0.0_dp
       scale = 0.0_dp
       if ((i <= m) .and. (i /= n)) then
          scale = sum(abs(a(i,l:n)))
          if (abs(scale) > 0.0_dp) then
             a(i,l:n) = a(i,l:n)/scale
             s = dot_product(a(i,l:n),a(i,l:n))
             f = a(i,l)
             g = -sign(sqrt(s),f)
             h = f*g-s
             a(i,l) = f-g
             rv1(l:n) = a(i,l:n)/h
             tempm(l:m) = matmul(a(l:m,l:n),a(i,l:n))
             a(l:m,l:n) = a(l:m,l:n)+outerprod(tempm(l:m),rv1(l:n))
             a(i,l:n)   = scale*a(i,l:n)
          end if
       end if
    end do
    anorm = maxval(abs(w)+abs(rv1))
    do i=n, 1, -1
       if (i < n) then
          if (abs(g) > 0.0_dp) then
             v(l:n,i)   = (a(i,l:n)/a(i,l))/g
             tempn(l:n) = matmul(a(i,l:n),v(l:n,l:n))
             v(l:n,l:n) = v(l:n,l:n)+outerprod(v(l:n,i),tempn(l:n))
          end if
          v(i,l:n) = 0.0_dp
          v(l:n,i) = 0.0_dp
       end if
       v(i,i) = 1.0_dp
       g = rv1(i)
       l = i
    end do
    do i=min(m,n), 1, -1
       l = i+1
       g = w(i)
       a(i,l:n) = 0.0_dp
       if (abs(g) > 0.0_dp) then
          g = 1.0_dp/g
          tempn(l:n) = (matmul(a(l:m,i),a(l:m,l:n))/a(i,i))*g
          if (l <= n) & ! pgfortran out-of-bounds in debug mode
               a(i:m,l:n) = a(i:m,l:n)+outerprod(a(i:m,i),tempn(l:n))
          a(i:m,i)   = a(i:m,i)*g
       else
          a(i:m,i) = 0.0_dp
       end if
       a(i,i) = a(i,i)+1.0_dp
    end do
    do k=n, 1, -1
       do its=1, 30
          do l=k, 1, -1
             nm = l-1
             ! if ((abs(rv1(l))+anorm) == anorm) exit
             ! if ((abs(w(nm))+anorm) == anorm) then
             if (eq(abs(rv1(l))+anorm, anorm)) exit
             if (eq(abs(w(nm))+anorm, anorm)) then
                c = 0.0_dp
                s = 1.0_dp
                do i=l, k
                   f = s*rv1(i)
                   rv1(i) = c*rv1(i)
                   ! if ((abs(f)+anorm) == anorm) exit
                   if (eq(abs(f)+anorm, anorm)) exit
                   g = w(i)
                   h = pythag(f,g)
                   w(i) = h
                   h = 1.0_dp/h
                   c =  (g*h)
                   s = -(f*h)
                   tempm(1:m) = a(1:m,nm)
                   a(1:m,nm)  = a(1:m,nm)*c+a(1:m,i)*s
                   a(1:m,i)   = -tempm(1:m)*s+a(1:m,i)*c
                end do
                exit
             end if
          end do
          z = w(k)
          if (l == k) then
             if (z < 0.0_dp) then
                w(k) = -z
                v(1:n,k) = -v(1:n,k)
             end if
             exit
          end if
          if (its == 30) stop 'svdcmp_dp: no convergence in svdcmp_dp'
          x = w(l)
          nm = k-1
          y = w(nm)
          g = rv1(nm)
          h = rv1(k)
          f = ((y-z)*(y+z)+(g-h)*(g+h))/(2.0_dp*h*y)
          g = pythag(f,1.0_dp)
          f = ((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x
          c = 1.0_dp
          s = 1.0_dp
          do j=l, nm
             i = j+1
             g = rv1(i)
             y = w(i)
             h = s*g
             g = c*g
             z = pythag(f,h)
             rv1(j) = z
             c = f/z
             s = h/z
             f =  (x*c)+(g*s)
             g = -(x*s)+(g*c)
             h = y*s
             y = y*c
             tempn(1:n) = v(1:n,j)
             v(1:n,j)   = v(1:n,j)*c+v(1:n,i)*s
             v(1:n,i)   = -tempn(1:n)*s+v(1:n,i)*c
             z = pythag(f,h)
             w(j) = z
             if (abs(z) > 0.0_dp) then
                z = 1.0_dp/z
                c = f*z
                s = h*z
             end if
             f =  (c*g)+(s*y)
             x = -(s*g)+(c*y)
             tempm(1:m) = a(1:m,j)
             a(1:m,j)   = a(1:m,j)*c+a(1:m,i)*s
             a(1:m,i)   = -tempm(1:m)*s+a(1:m,i)*c
          end do
          rv1(l) = 0.0_dp
          rv1(k) = f
          w(k)   = x
       end do
    end do

  END SUBROUTINE svdcmp_dp

  SUBROUTINE svdcmp_sp(a,w,v)

    use mo_utils, only: eq

    IMPLICIT NONE

    REAL(sp), DIMENSION(:,:), INTENT(INOUT) :: a
    REAL(sp), DIMENSION(:),   INTENT(OUT)   :: w
    REAL(sp), DIMENSION(:,:), INTENT(OUT)   :: v

    INTEGER(i4) :: i, its, j, k, l, m, n, nm
    REAL(sp)    :: c, f, g, h, s, scale, x, y, z, anorm
    REAL(sp), DIMENSION(size(a,1)) :: tempm
    REAL(sp), DIMENSION(size(a,2)) :: rv1, tempn

    m = size(a,1)
    if (size(a,2) /= size(v,1)) stop 'Error svdcmp_sp: size(a,2) /= size(v,1)'
    if (size(a,2) /= size(v,2)) stop 'Error svdcmp_sp: size(a,2) /= size(v,2)'
    if (size(a,2) /= size(w))   stop 'Error svdcmp_sp: size(a,2) /= size(w)'
    n = size(a,2)
    g     = 0.0_sp
    scale = 0.0_sp
    do i=1, n
       l = i+1
       rv1(i) = scale*g
       g     = 0.0_sp
       scale = 0.0_sp
       if (i <= m) then
          scale = sum(abs(a(i:m,i)))
          if (abs(scale) > 0.0_sp) then
             a(i:m,i) = a(i:m,i)/scale
             s = dot_product(a(i:m,i),a(i:m,i))
             f = a(i,i)
             g = -sign(sqrt(s),f)
             h = f*g-s
             a(i,i) = f-g
             tempn(l:n) = matmul(a(i:m,i),a(i:m,l:n))/h
             if (l <= n) & ! pgfortran out-of-bounds in debug mode
                  a(i:m,l:n) = a(i:m,l:n)+outerprod(a(i:m,i),tempn(l:n))
             a(i:m,i)   = scale*a(i:m,i)
          end if
       end if
       w(i) = scale*g
       g     = 0.0_sp
       scale = 0.0_sp
       if ((i <= m) .and. (i /= n)) then
          scale = sum(abs(a(i,l:n)))
          if (abs(scale) > 0.0_sp) then
             a(i,l:n) = a(i,l:n)/scale
             s = dot_product(a(i,l:n),a(i,l:n))
             f = a(i,l)
             g = -sign(sqrt(s),f)
             h = f*g-s
             a(i,l) = f-g
             rv1(l:n) = a(i,l:n)/h
             tempm(l:m) = matmul(a(l:m,l:n),a(i,l:n))
             a(l:m,l:n) = a(l:m,l:n)+outerprod(tempm(l:m),rv1(l:n))
             a(i,l:n)   = scale*a(i,l:n)
          end if
       end if
    end do
    anorm = maxval(abs(w)+abs(rv1))
    do i=n, 1, -1
       if (i < n) then
          if (abs(g) > 0.0_sp) then
             v(l:n,i)   = (a(i,l:n)/a(i,l))/g
             tempn(l:n) = matmul(a(i,l:n),v(l:n,l:n))
             v(l:n,l:n) = v(l:n,l:n)+outerprod(v(l:n,i),tempn(l:n))
          end if
          v(i,l:n) = 0.0_sp
          v(l:n,i) = 0.0_sp
       end if
       v(i,i) = 1.0_sp
       g = rv1(i)
       l = i
    end do
    do i=min(m,n), 1, -1
       l = i+1
       g = w(i)
       a(i,l:n) = 0.0_sp
       if (abs(g) > 0.0_sp) then
          g = 1.0_sp/g
          tempn(l:n) = (matmul(a(l:m,i),a(l:m,l:n))/a(i,i))*g
          if (l <= n) & ! pgfortran out-of-bounds in debug mode
               a(i:m,l:n) = a(i:m,l:n)+outerprod(a(i:m,i),tempn(l:n))
          a(i:m,i)   = a(i:m,i)*g
       else
          a(i:m,i) = 0.0_sp
       end if
       a(i,i) = a(i,i)+1.0_sp
    end do
    do k=n, 1, -1
       do its=1, 30
          do l=k, 1, -1
             nm = l-1
             ! if ((abs(rv1(l))+anorm) == anorm) exit
             ! if ((abs(w(nm))+anorm) == anorm) then
             if (eq(abs(rv1(l))+anorm, anorm)) exit
             if (eq(abs(w(nm))+anorm, anorm)) then
                c = 0.0_sp
                s = 1.0_sp
                do i=l, k
                   f = s*rv1(i)
                   rv1(i) = c*rv1(i)
                   ! if ((abs(f)+anorm) == anorm) exit
                   if (eq(abs(f)+anorm, anorm)) exit
                   g = w(i)
                   h = pythag(f,g)
                   w(i) = h
                   h = 1.0_sp/h
                   c =  (g*h)
                   s = -(f*h)
                   tempm(1:m) = a(1:m,nm)
                   a(1:m,nm)  = a(1:m,nm)*c+a(1:m,i)*s
                   a(1:m,i)   = -tempm(1:m)*s+a(1:m,i)*c
                end do
                exit
             end if
          end do
          z = w(k)
          if (l == k) then
             if (z < 0.0_sp) then
                w(k) = -z
                v(1:n,k) = -v(1:n,k)
             end if
             exit
          end if
          if (its == 30) stop 'svdcmp_sp: no convergence in svdcmp_sp'
          x = w(l)
          nm = k-1
          y = w(nm)
          g = rv1(nm)
          h = rv1(k)
          f = ((y-z)*(y+z)+(g-h)*(g+h))/(2.0_sp*h*y)
          g = pythag(f,1.0_sp)
          f = ((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x
          c = 1.0_sp
          s = 1.0_sp
          do j=l, nm
             i = j+1
             g = rv1(i)
             y = w(i)
             h = s*g
             g = c*g
             z = pythag(f,h)
             rv1(j) = z
             c = f/z
             s = h/z
             f =  (x*c)+(g*s)
             g = -(x*s)+(g*c)
             h = y*s
             y = y*c
             tempn(1:n) = v(1:n,j)
             v(1:n,j)   = v(1:n,j)*c+v(1:n,i)*s
             v(1:n,i)   = -tempn(1:n)*s+v(1:n,i)*c
             z = pythag(f,h)
             w(j) = z
             if (abs(z) > 0.0_sp) then
                z = 1.0_sp/z
                c = f*z
                s = h*z
             end if
             f =  (c*g)+(s*y)
             x = -(s*g)+(c*y)
             tempm(1:m) = a(1:m,j)
             a(1:m,j)   = a(1:m,j)*c+a(1:m,i)*s
             a(1:m,i)   = -tempm(1:m)*s+a(1:m,i)*c
          end do
          rv1(l) = 0.0_sp
          rv1(k) = f
          w(k)   = x
       end do
    end do

  END SUBROUTINE svdcmp_sp

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

  SUBROUTINE svdfit_dp(ix, iy, isig, oa, ov, ow, ochisq, func)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:),   INTENT(IN)  :: ix, iy, isig
    REAL(dp), DIMENSION(:),   INTENT(OUT) :: oa, ow
    REAL(dp), DIMENSION(:,:), INTENT(OUT) :: ov
    REAL(dp),                 INTENT(OUT) :: ochisq
    INTERFACE
       FUNCTION func(x,n)
         USE mo_kind, ONLY: i4, dp
         IMPLICIT NONE
         REAL(dp),    INTENT(IN)   :: x
         INTEGER(i4), INTENT(IN)   :: n
         REAL(dp),    DIMENSION(n) :: func
       END FUNCTION func
    END INTERFACE

    REAL(dp), DIMENSION(size(ix))   :: x
    REAL(dp), DIMENSION(size(iy))   :: y
    REAL(dp), DIMENSION(size(isig)) :: sig
    REAL(dp), DIMENSION(size(oa))   :: a
    REAL(dp), DIMENSION(size(ow))   :: w
    REAL(dp), DIMENSION(size(ov,1),size(ov,2)) :: v
    REAL(dp) :: chisq

    REAL(dp), PARAMETER :: TOL = 1.0e-5_dp
    INTEGER(i4) :: i, ma, n
    REAL(dp), DIMENSION(size(x))         :: b, sigi
    REAL(dp), DIMENSION(size(x),size(a)) :: u, usav

    if (size(ix) /= size(iy))   stop 'Error svdfit_dp: size(x) /= size(y)'
    if (size(iy) /= size(isig)) stop 'Error svdfit_dp: size(y) /= size(sig)'
    if (size(oa) /= size(ov,1)) stop 'Error svdfit_dp: size(a) /= size(v,1)'
    if (size(oa) /= size(ov,2)) stop 'Error svdfit_dp: size(a) /= size(v,2)'
    if (size(oa) /= size(ow))   stop 'Error svdfit_dp: size(a) /= size(w)'

    x   = real(ix,dp)
    y   = real(iy,dp)
    sig = real(isig,dp)

    n  = size(x)
    ma = size(a)
    sigi = 1.0_dp/sig
    b    = y*sigi
    do i=1, n
       usav(i,:) = func(x(i),ma)
    end do
    u    = usav*spread(sigi,dim=2,ncopies=ma)
    usav = u
    call svdcmp(u,w,v)
    where (w < TOL*maxval(w)) w = 0.0_dp
    call svdksb(u,w,v,b,a)
    chisq = vabs(matmul(usav,a)-b)**2

    oa = real(a,dp)
    ow = real(w,dp)
    ov = real(v,dp)
    ochisq = real(chisq,dp)

  END SUBROUTINE svdfit_dp

  SUBROUTINE svdfit_sp(ix, iy, isig, oa, ov, ow, ochisq, func)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:),   INTENT(IN)  :: ix, iy, isig
    REAL(sp), DIMENSION(:),   INTENT(OUT) :: oa, ow
    REAL(sp), DIMENSION(:,:), INTENT(OUT) :: ov
    REAL(sp),                 INTENT(OUT) :: ochisq
    INTERFACE
       FUNCTION func(x,n)
         USE mo_kind, ONLY: i4, sp
         IMPLICIT NONE
         REAL(sp),    INTENT(IN)   :: x
         INTEGER(i4), INTENT(IN)   :: n
         REAL(sp),    DIMENSION(n) :: func
       END FUNCTION func
    END INTERFACE

    REAL(sp), DIMENSION(size(ix))   :: x
    REAL(sp), DIMENSION(size(iy))   :: y
    REAL(sp), DIMENSION(size(isig)) :: sig
    REAL(sp), DIMENSION(size(oa))   :: a
    REAL(sp), DIMENSION(size(ow))   :: w
    REAL(sp), DIMENSION(size(ov,1),size(ov,2)) :: v
    REAL(sp) :: chisq

    REAL(sp), PARAMETER :: TOL = 1.0e-5_sp
    INTEGER(i4) :: i, ma, n
    REAL(sp), DIMENSION(size(x))         :: b, sigi
    REAL(sp), DIMENSION(size(x),size(a)) :: u, usav

    if (size(ix) /= size(iy))   stop 'Error svdfit_sp: size(x) /= size(y)'
    if (size(iy) /= size(isig)) stop 'Error svdfit_sp: size(y) /= size(sig)'
    if (size(oa) /= size(ov,1)) stop 'Error svdfit_sp: size(a) /= size(v,1)'
    if (size(oa) /= size(ov,2)) stop 'Error svdfit_sp: size(a) /= size(v,2)'
    if (size(oa) /= size(ow))   stop 'Error svdfit_sp: size(a) /= size(w)'

    x   = real(ix,sp)
    y   = real(iy,sp)
    sig = real(isig,sp)

    n  = size(x)
    ma = size(a)
    sigi = 1.0_sp/sig
    b    = y*sigi
    do i=1, n
       usav(i,:) = func(x(i),ma)
    end do
    u    = usav*spread(sigi,dim=2,ncopies=ma)
    usav = u
    call svdcmp(u,w,v)
    where (w < TOL*maxval(w)) w = 0.0_sp
    call svdksb(u,w,v,b,a)
    chisq = vabs(matmul(usav,a)-b)**2

    oa = real(a,sp)
    ow = real(w,sp)
    ov = real(v,sp)
    ochisq = real(chisq,sp)

  END SUBROUTINE svdfit_sp

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

  SUBROUTINE svdvar_dp(v, w, cvm)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:,:), INTENT(IN)  :: v
    REAL(dp), DIMENSION(:),   INTENT(IN)  :: w
    REAL(dp), DIMENSION(:,:), INTENT(OUT) :: cvm

    INTEGER(i4) :: ma
    REAL(dp), DIMENSION(size(w)) :: wti
    REAL(dp), DIMENSION(size(w)) :: wtmp

    if (size(v,1) /= size(v,2))   stop 'Error svdvar_dp: size(v,1) /= size(v,2)'
    if (size(v,1) /= size(w))     stop 'Error svdvar_dp: size(v,1) /= size(w)'
    if (size(v,1) /= size(cvm,1)) stop 'Error svdvar_dp: size(v,1) /= size(cvm,1)'
    if (size(v,1) /= size(cvm,2)) stop 'Error svdvar_dp: size(v,1) /= size(cvm,2)'

    ma = size(v,1)
    wtmp = w
    where (abs(w) < tiny(1.0_dp)) wtmp = 1.0_dp
    wti = 1.0_dp/(wtmp*wtmp)
    where (abs(w) < tiny(1.0_dp)) wti = 0.0_dp
    cvm = v*spread(wti,dim=1,ncopies=ma)
    cvm = matmul(cvm,transpose(v))

  END SUBROUTINE svdvar_dp

  SUBROUTINE svdvar_sp(v, w, cvm)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:,:), INTENT(IN)  :: v
    REAL(sp), DIMENSION(:),   INTENT(IN)  :: w
    REAL(sp), DIMENSION(:,:), INTENT(OUT) :: cvm

    INTEGER(i4) :: ma
    REAL(sp), DIMENSION(size(w)) :: wti
    REAL(sp), DIMENSION(size(w)) :: wtmp

    if (size(v,1) /= size(v,2))   stop 'Error svdvar_sp: size(v,1) /= size(v,2)'
    if (size(v,1) /= size(w))     stop 'Error svdvar_sp: size(v,1) /= size(w)'
    if (size(v,1) /= size(cvm,1)) stop 'Error svdvar_sp: size(v,1) /= size(cvm,1)'
    if (size(v,1) /= size(cvm,2)) stop 'Error svdvar_sp: size(v,1) /= size(cvm,2)'

    ma = size(v,1)
    wtmp = w
    where (abs(w) < tiny(1.0_sp)) wtmp = 1.0_sp
    wti = 1.0_sp/(wtmp*wtmp)
    where (abs(w) < tiny(1.0_sp)) wti = 0.0_sp
    cvm = v*spread(wti,dim=1,ncopies=ma)
    cvm = matmul(cvm,transpose(v))

  END SUBROUTINE svdvar_sp

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

  ! From numerical recipes documentation
  ! Returns the length of a vector v in L2 norm, that is,the square root of the sum
  ! of the squares of the components. (For complex types, t should be between the vector and its complex conjugate.)
  FUNCTION vabs_dp(v)

    REAL(dp), DIMENSION(:), INTENT(IN) :: v
    REAL(dp)                           :: vabs_dp

    vabs_dp = sqrt(dot_product(v,v))

  END FUNCTION vabs_dp

  FUNCTION vabs_sp(v)

    REAL(sp), DIMENSION(:), INTENT(IN) :: v
    REAL(sp)                           :: vabs_sp

    vabs_sp = sqrt(dot_product(v,v))

  END FUNCTION vabs_sp

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

END MODULE mo_fit


      SUBROUTINE chebpc(c,d,n)
      INTEGER n,NMAX
      REAL c(n),d(n)
      PARAMETER (NMAX=50)
      INTEGER j,k
      REAL sv,dd(NMAX)
      do 11 j=1,n
        d(j)=0.
        dd(j)=0.
11    continue
      d(1)=c(n)
      do 13 j=n-1,2,-1
        do 12 k=n-j+1,2,-1
          sv=d(k)
          d(k)=2.*d(k-1)-dd(k)
          dd(k)=sv
12      continue
        sv=d(1)
        d(1)=-dd(1)+c(j)
        dd(1)=sv
13    continue
      do 14 j=n,2,-1
        d(j)=d(j-1)-dd(j)
14    continue
      d(1)=-dd(1)+0.5*c(1)
      return
      END

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


!edm
      subroutine euclidean_distance_matrix(x, y, nsamples, nfeat, r)

      implicit none

      double precision, intent(in) :: x(nfeat, nsamples)
      double precision, intent(in) :: y(nfeat, nsamples)
      integer, intent(in) :: nsamples
      integer, intent(in) :: nfeat
      double precision, intent(out) :: r(nsamples, nsamples)

      integer :: i, j, k
      double precision :: tmp

!$OMP PARALLEL DO PRIVATE (tmp)
      do i = 1, nsamples
          do j = 1, nsamples
              tmp = 0.0
              do k = 1, nfeat
                  tmp = (x(k,i) - y(k,j))**2 + tmp
              enddo
              r(i,j) = tmp
          enddo
      enddo
!$OMP END PARALLEL DO

      end subroutine euclidean_distance_matrix


PROGRAM rel_max
IMPLICIT NONE
REAL, DIMENSION(:,:), ALLOCATABLE :: matrix
INTEGER, DIMENSION(1:2) :: loc
CHARACTER, DIMENSION(:,:), ALLOCATABLE :: max_map
INTEGER :: rows, cols, i, j

OPEN (1, FILE="matrix.dat", STATUS='OLD', ACTION='READ')
READ(1, *) rows, cols
ALLOCATE(matrix(1:rows, 1:cols), max_map(1:rows, 1:cols))
READ(1, *) matrix
WRITE(*, *) "DATA:"
WRITE(*, '(10F12.1)') ((matrix(i, j), j = 1, cols), i = 1, rows)

max_map = '_'
DO i = 2, rows - 1
  DO j = 2, cols - 1
    loc = MAXLOC(matrix(i-1:i+1,j-1:j+1))
    !WRITE(*, *) loc
    !WRITE(*, '(8F12.1)') MAXVAL(matrix(i-1:i+1,j-1:j+1))
    !WRITE(*, *) i, loc(1),  j .eq. loc(2)
    IF ((loc(1) .eq. 2) .and. (loc(2)) .eq. 2) THEN
      max_map(i, j) = 'X'
    END IF
  END DO
END DO

WRITE(*, *) "MAXIMA LOCATIONS:"
WRITE(*, '(10A12)') ((max_map(i, j), j = 1, cols), i = 1, rows)
END PROGRAM rel_max


 	Program oscillator
 	Implicit none
c declarations
	Real*8 dt, min, max, t, y(5)
c n: number of equations (the 'dimension' of the standard form)
	Integer	n
C number of component
        parameter (n=2)
C starting and end points
        min=0.0D0
        max=10.0D0
C time step
        dt=0.1D0
C initial position
        y(1)=0.2D0
C initial velocity
        y(2)=0.0D0

c open file to output
        Open(6, File='rk2.dat')
c do n steps of Runga-Kutta algorithm
	Do t=min, max, dt
	  Call rk2(t, dt, y, n)
          Write (6,*) t, y(1)
   	enddo
c
	Close(6)
	Stop 'data saved in rk2.dat'
        End
c------------------------end of main program------------------------
c
c second-order Runge-Kutta subroutine
	Subroutine rk2(t, dt, y, n)
	Implicit none
c declarations
	Real*8 deriv, h, t, dt, y(1)
        Real*8 k1(5), k2(5), t1(5)
     	Integer i, n
     	h=dt/2.0D0
	Do i = 1,n
	   k1(i) = dt * deriv(t, y, i)
	   t1(i) = y(i) + 0.5D0*k1(i)
   	enddo
	Do i = 1,n
	   k2(i) = dt * deriv(t+h, t1, i)
	   y(i) = y(i) + k2(i)
   	enddo
c
	Return
	End

c function which returns the derivatives
	Function deriv(x, temp, i)
C 2 function components: dx/dt = v(t),   dv/dt = -w**2*x(t) -a*v
C the second term is damping term
	Implicit none
c declarations
	Real*8 deriv, x, temp(2), omega, alpha
	Integer i
	data omega /3.13d0/
	data alpha /0.5d0/
c
	If (i .EQ. 1) deriv=temp(2)
	If (i .EQ. 2) deriv=-temp(1) * omega**2
	Return
	End


module gauss
  implicit none

  private
  public echelon, reduce

  interface echelon
    module procedure echelon_dummy
    module procedure echelon_det_sign
  end interface echelon

  contains

  subroutine reduce(M)
    real, intent(inout) :: M(:, :)

    integer :: i
    real :: mii

    call echelon_dummy(M)
    do i = 1, max(size(M, 1), size(M, 2))
      mii = M(i, i)
      if (mii /= 1 .and. mii /= 0) then
        call mul_row(M, i, 1 / mii)
      end if
    end do
  end subroutine reduce

  subroutine echelon_dummy(M)
    real, intent(inout) :: M(:, :)
    integer :: dummy
    call echelon_sub(M, 1, 1, dummy)
  end subroutine echelon_dummy

  subroutine echelon_det_sign(M, det_sign)
    real, intent(inout) :: M(:, :)
    integer, intent(inout) :: det_sign
    det_sign = 1
    call echelon_sub(M, 1, 1, det_sign)
  end subroutine

  recursive subroutine echelon_sub(A, n, m, det_sign)
    real, intent(inout) :: A(:, :)
    integer, intent(in) :: n, m
    integer, intent(inout) :: det_sign

    integer :: i
    integer :: non_zero_row

    if (n <= size(A, 1) .and. m <= size(A, 2)) then
      non_zero_row = 0
      do i = size(A, 2), m, -1
        if (A(n, i) /= 0) then
          non_zero_row = i
        end if
      end do
      if (non_zero_row /= 0) then
        if (non_zero_row /= m) then
          call swap_rows(A, non_zero_row, m)
          det_sign = det_sign * (-1)
        end if
        do i = 1, size(A, 2)
          if (i /= m .and. A(n, i) /= 0) then
            call add_row(A, i, m, -A(n, i) / A(n, m))
          end if
        end do
      end if
      call echelon_sub(A, n + 1, m + 1, det_sign)
    end if
  end subroutine echelon_sub

  subroutine swap_rows(M, row1, row2)
    real, intent(inout) :: M(:, :)
    integer, intent(in) :: row1, row2

    real, dimension(size(M, 1)) :: tmp
    call copy_vec(tmp, M(:, row1))
    call copy_vec(M(:, row1), M(:, row2))
    call copy_vec(M(:, row2), tmp)
  end subroutine swap_rows

  subroutine mul_row(M, rowi, n)
    real, intent(inout) :: M(:, :)
    integer, intent(in) :: rowi
    real, intent(in) :: n

    integer :: i
    do i = 1, size(M, 1)
      M(i, rowi) = M(i, rowi) * n
    end do
  end subroutine mul_row

  subroutine add_row(M, row1, row2, n)
    real, intent(inout) :: M(:, :)
    integer, intent(in) :: row1, row2
    real, intent(in) :: n

    integer :: i
    do i = 1, size(M, 1)
      M(i, row1) = M(i, row1) + M(i, row2) * n
    end do
  end subroutine add_row

  subroutine copy_vec(to, from)
    real, intent(out) :: to(:)
    real, intent(in) :: from(size(to))

    integer :: i
    do i = 1, size(to)
      to(i) = from(i)
    end do
  end subroutine copy_vec
end module gauss


program test_CIJ_tandon_and_weng

use anisotropy_ajn

implicit none

      integer, parameter :: i4 = selected_int_kind(9) ; ! long int
      integer, parameter :: r4 = selected_real_kind(6,37) ; ! SP
      integer, parameter :: r8 = selected_real_kind(15,307) ; ! DP

!  ** precision selector
      integer, parameter :: rs = r8

!  ** maths constants and other useful things
      real(rs), parameter :: pi = 3.141592653589793238462643 ;
      real(rs), parameter :: to_rad = 1.74532925199433e-002 ;
      real(rs), parameter :: to_deg = 57.2957795130823e0 ;
      real(rs), parameter :: to_km = 111.194926644559 ;

      real(rs), parameter :: big_number = 10.e36 ;

   real(rs)   :: CC(6,6),CCexp(6,6),vp,vs,rho,vpi,vsi,rhoi,c,del,rhoout

   vp = 5.8d3
   vs = 3.46d3
   rho = 2.92d3

   del = 0.01
   c = 0.02

   vpi = 4.d3
   vsi = 0.d0
   rhoi = 2.2d3

   call CIJ_tandon_and_weng(vp,vs,rho,del,c,vpi,vsi,rhoi,CC,rhoout)

   write(*,'(a)')  'Output should look like: (x10^7)'
   write(*,'(a)') &
'    3.2634    0.9878    0.9878    0.0000    0.0000    0.0000',&
'    0.9878    3.3358    0.9784    0.0000    0.0000    0.0000',&
'    0.9878    0.9784    3.3358    0.0000    0.0000    0.0000',&
'    0.0000    0.0000    0.0000    1.1787    0.0000    0.0000',&
'    0.0000    0.0000    0.0000    0.0000    0.5574    0.0000',&
'    0.0000    0.0000    0.0000    0.0000    0.0000    0.5574'

   CCexp = 1.d7 * reshape( &
   (/  3.2634,  0.9878,  0.9878,  0.0000,  0.0000,  0.0000, &
       0.9878,  3.3358,  0.9784,  0.0000,  0.0000,  0.0000, &
       0.9878,  0.9784,  3.3358,  0.0000,  0.0000,  0.0000, &
       0.0000,  0.0000,  0.0000,  1.1787,  0.0000,  0.0000, &
       0.0000,  0.0000,  0.0000,  0.0000,  0.5574,  0.0000, &
       0.0000,  0.0000,  0.0000,  0.0000,  0.0000,  0.5574  /), (/6,6/))

   write(*,'(/a)') 'Output: (x10^7)'
   write(*,'(6f10.4)') CC/1.d7

   ! Different if any value differs by more than 0.1 %
   if (any(abs(CC - CCexp) > abs(CCexp/1.d4))) then
      write(*,'(/a,e10.4)') 'TEST FAILED: total difference between sum of matrices = ',sum(abs(CC-CCexp))
   else
      write(*,'(/a)') 'Test passed'
   endif

end program test_CIJ_tandon_and_weng


!  cfd_lax.f90
!
!  FUNCTIONS:
!  cfd_lax - Entry point of console application.
!

!****************************************************************************
!
!  PROGRAM: cfd_lax
! by mehrdad baba hosein pour
!  PURPOSE:  Entry point for the console application.
!  beyond sky!
!****************************************************************************

 program wave_lax
implicit none
integer::i,n
integer,parameter:: ix=201,nt=400
real*8::u(nt,ix),a,dt,dx,l,pi,u1(nt,ix)
pi=2*asin(1.d0)
a=0.01
dt=0.04
l=1
dx=l/(ix-1)
print*,'qourant number is = ',a*dt/dx

!exact_solution
do n=1,nt
 do i=1,ix
    u1(n,i)=sin(2*pi*(i-1)*(dx-a*dt)*5)
 end do
end do

!initial condition
do i=1,ix
    u(1,i)=sin(2.d0*pi*(i-1)*dx*5)
end do

!solve_wave_equation
do n=1,nt-1
    do i=2,ix-1
       u(n+1,i)=(u(n,i+1)+u(n,i-1))/2.d0-a*dt/dx*((u(n,i+1)-u(n,i-1))/2.d0)
    end do
end do
open (1,file='analysis_result_lax.plt')        !analysis_result
do n=1,nt
    write(1,*)'variables="x","u1"'
    write(1,*)'zone'
    do i=1,ix
        write(1,*) dx*(i-1),u1(n,i)
    end do
end do
open (2,file='computational_result_lax.plt')   ! computational_result
do n=1,nt
    write(2,*)'variables="x","u"'
    write(2,*)'zone'
    do i=1,ix
        write(2,*) dx*(i-1),u(n,i)
    end do
end do
print*,'>>> please inter <<<'

pause
    end program wave_lax


!*********************
subroutine bc(psi,i1,i2,j1,j2)
! sets the boundary conditions
! input is the grid and the indices for the interior cells
    use numz
    implicit none
    integer,intent(in):: i1,i2,j1,j2
    real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: psi
    psi(i1-1,:)=0.0_b8
    psi(i2+1,:)=0.0_b8
    psi(:,j1-1)=0.0_b8
    psi(:,j2+1)=0.0_b8
end subroutine bc
!*********************
subroutine do_jacobi(psi,new_psi,diff,i1,i2,j1,j2)
! does a single Jacobi iteration step
! input is the grid and the indices for the interior cells
! new_psi is temp storage for the the updated grid
! output is the updated grid in psi and diff which is
! the sum of the differences between the old and new grids
    use numz
    use constants
    implicit none
    integer,intent(in) :: i1,i2,j1,j2
    real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: psi
    real(b8),dimension(i1-1:i2+1,j1-1:j2+1):: new_psi
    real(b8) diff
    integer i,j
    real(b8) y
    diff=0.0_b8
    do j=j1,j2
        do i=i1,i2
!            y=j*dy
            new_psi(i,j)=a1*psi(i+1,j) + a2*psi(i-1,j) + &
                         a3*psi(i,j+1) + a4*psi(i,j-1) - &
                         a5*for(i,j)
!                         a5*force(y)
            diff=diff+abs(new_psi(i,j)-psi(i,j))
         enddo
     enddo
    psi(i1:i2,j1:j2)=new_psi(i1:i2,j1:j2)
end subroutine do_jacobi
!*********************
function force(y)
    use numz
    use input
    use constants
    implicit none
    real(b8) force,y
    force=-alpha*sin(y*a6)
end function force
!*********************
subroutine do_force (i1,i2,j1,j2)
! sets the force conditions
! input is the grid and the indices for the interior cells
    use numz
    use constants, only:for,dy
    use face, only : force
    implicit none
    integer,intent(in):: i1,i2,j1,j2
    real(b8) y
    integer i,j
    do i=i1,i2
        do j=j1,j2
            y=j*dy
            for(i,j)=force(y)
        enddo
    enddo
end subroutine


      SUBROUTINE MB01WD( DICO, UPLO, TRANS, HESS, N, ALPHA, BETA, R,
     $                   LDR, A, LDA, T, LDT, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the matrix formula
C     _
C     R = alpha*( op( A )'*op( T )'*op( T ) + op( T )'*op( T )*op( A ) )
C         + beta*R,                                                  (1)
C
C     if DICO = 'C', or
C     _
C     R = alpha*( op( A )'*op( T )'*op( T )*op( A ) -  op( T )'*op( T ))
C         + beta*R,                                                  (2)
C                                                             _
C     if DICO = 'D', where alpha and beta are scalars, R, and R are
C     symmetric matrices, T is a triangular matrix, A is a general or
C     Hessenberg matrix, and op( M ) is one of
C
C        op( M ) = M   or   op( M ) = M'.
C
C     The result is overwritten on R.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the formula to be evaluated, as follows:
C             = 'C':  formula (1), "continuous-time" case;
C             = 'D':  formula (2), "discrete-time" case.
C
C     UPLO    CHARACTER*1
C             Specifies which triangles of the symmetric matrix R and
C             triangular matrix T are given, as follows:
C             = 'U':  the upper triangular parts of R and T are given;
C             = 'L':  the lower triangular parts of R and T are given;
C
C     TRANS   CHARACTER*1
C             Specifies the form of op( M ) to be used, as follows:
C             = 'N':  op( M ) = M;
C             = 'T':  op( M ) = M';
C             = 'C':  op( M ) = M'.
C
C     HESS    CHARACTER*1
C             Specifies the form of the matrix A, as follows:
C             = 'F':  matrix A is full;
C             = 'H':  matrix A is Hessenberg (or Schur), either upper
C                     (if UPLO = 'U'), or lower (if UPLO = 'L').
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices R, A, and T.  N >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar alpha. When alpha is zero then the arrays A
C             and T are not referenced.
C
C     BETA    (input) DOUBLE PRECISION
C             The scalar beta. When beta is zero then the array R need
C             not be set before entry.
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,N)
C             On entry with UPLO = 'U', the leading N-by-N upper
C             triangular part of this array must contain the upper
C             triangular part of the symmetric matrix R.
C             On entry with UPLO = 'L', the leading N-by-N lower
C             triangular part of this array must contain the lower
C             triangular part of the symmetric matrix R.
C             On exit, the leading N-by-N upper triangular part (if
C             UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of
C             this array contains the corresponding triangular part of
C                                 _
C             the computed matrix R.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,N).
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A. If HESS = 'H' the elements below the
C             first subdiagonal, if UPLO = 'U', or above the first
C             superdiagonal, if UPLO = 'L', need not be set to zero,
C             and are not referenced if DICO = 'D'.
C             On exit, the leading N-by-N part of this array contains
C             the following matrix product
C                alpha*T'*T*A, if TRANS = 'N', or
C                alpha*A*T*T', otherwise,
C             if DICO = 'C', or
C                T*A, if TRANS = 'N', or
C                A*T, otherwise,
C             if DICO = 'D' (and in this case, these products have a
C             Hessenberg form, if HESS = 'H').
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     T       (input) DOUBLE PRECISION array, dimension (LDT,N)
C             If UPLO = 'U', the leading N-by-N upper triangular part of
C             this array must contain the upper triangular matrix T and
C             the strictly lower triangular part need not be set to zero
C             (and it is not referenced).
C             If UPLO = 'L', the leading N-by-N lower triangular part of
C             this array must contain the lower triangular matrix T and
C             the strictly upper triangular part need not be set to zero
C             (and it is not referenced).
C
C     LDT     INTEGER
C             The leading dimension of array T.  LDT >= MAX(1,N).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -k, the k-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The matrix expression (1) or (2) is efficiently evaluated taking
C     the structure into account. BLAS 3 operations (DTRMM, DSYRK and
C     their specializations) are used throughout.
C
C     NUMERICAL ASPECTS
C
C     If A is a full matrix, the algorithm requires approximately
C      3
C     N  operations, if DICO = 'C';
C            3
C     7/6 x N  operations, if DICO = 'D'.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix algebra, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO, HESS, TRANS, UPLO
      INTEGER           INFO, LDA, LDR, LDT, N
      DOUBLE PRECISION  ALPHA, BETA
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), R(LDR,*), T(LDT,*)
C     .. Local Scalars ..
      LOGICAL           DISCR, REDUC, TRANSP, UPPER
      CHARACTER         NEGTRA, SIDE
      INTEGER           I, INFO2, J
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DLASCL, DLASET, DSYRK, DTRMM, MB01YD, MB01ZD,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO = 0
      DISCR  = LSAME( DICO,  'D' )
      UPPER  = LSAME( UPLO,  'U' )
      TRANSP = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
      REDUC  = LSAME( HESS,  'H' )
C
      IF(      .NOT.( DISCR  .OR. LSAME( DICO,  'C' ) ) )THEN
         INFO = -1
      ELSE IF( .NOT.( UPPER  .OR. LSAME( UPLO,  'L' ) ) )THEN
         INFO = -2
      ELSE IF( .NOT.( TRANSP .OR. LSAME( TRANS, 'N' ) ) )THEN
         INFO = -3
      ELSE IF( .NOT.( REDUC  .OR. LSAME( HESS,  'F' ) ) )THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDR.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -13
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01WD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 )
     $   RETURN
C
      IF ( ALPHA.EQ.ZERO ) THEN
         IF ( BETA.EQ.ZERO ) THEN
C
C           Special case when both alpha = 0 and beta = 0.
C
            CALL DLASET( UPLO, N, N, ZERO, ZERO, R, LDR )
         ELSE
C
C           Special case alpha = 0.
C
            IF ( BETA.NE.ONE )
     $         CALL DLASCL( UPLO, 0, 0, ONE, BETA, N, N, R, LDR, INFO2 )
         END IF
         RETURN
      END IF
C
C     General case: alpha <> 0.
C
C     Compute (in A) T*A, if TRANS = 'N', or
C                    A*T, otherwise.
C
      IF ( TRANSP ) THEN
         SIDE   = 'R'
         NEGTRA = 'N'
      ELSE
         SIDE   = 'L'
         NEGTRA = 'T'
      END IF
C
      IF ( REDUC .AND. N.GT.2 ) THEN
         CALL MB01ZD( SIDE, UPLO, 'NoTranspose', 'Non-unit', N, N, 1,
     $                ONE, T, LDT, A, LDA, INFO2 )
      ELSE
         CALL DTRMM( SIDE, UPLO, 'NoTranspose', 'Non-unit', N, N, ONE,
     $               T, LDT, A, LDA )
      END IF
C
      IF( .NOT.DISCR ) THEN
C
C        Compute (in A) alpha*T'*T*A, if TRANS = 'N', or
C                       alpha*A*T*T', otherwise.
C
         IF ( REDUC .AND. N.GT.2 ) THEN
            CALL MB01ZD( SIDE, UPLO, 'Transpose', 'Non-unit', N, N, 1,
     $                   ALPHA, T, LDT, A, LDA, INFO2 )
         ELSE
            CALL DTRMM( SIDE, UPLO, 'Transpose', 'Non-unit', N, N,
     $                  ALPHA, T, LDT, A, LDA )
         END IF
C
C        Compute the required triangle of the result, using symmetry.
C
         IF ( UPPER ) THEN
            IF ( BETA.EQ.ZERO ) THEN
C
               DO 20 J = 1, N
                  DO 10 I = 1, J
                     R( I, J ) = A( I, J ) + A( J, I )
   10             CONTINUE
   20          CONTINUE
C
            ELSE
C
               DO 40 J = 1, N
                  DO 30 I = 1, J
                     R( I, J ) = A( I, J ) + A( J, I ) + BETA*R( I, J )
   30             CONTINUE
   40          CONTINUE
C
            END IF
C
         ELSE
C
            IF ( BETA.EQ.ZERO ) THEN
C
               DO 60 J = 1, N
                  DO 50 I = J, N
                     R( I, J ) = A( I, J ) + A( J, I )
   50             CONTINUE
   60          CONTINUE
C
            ELSE
C
               DO 80 J = 1, N
                  DO 70 I = J, N
                     R( I, J ) = A( I, J ) + A( J, I ) + BETA*R( I, J )
   70             CONTINUE
   80          CONTINUE
C
            END IF
C
         END IF
C
      ELSE
C
C        Compute (in R) alpha*A'*T'*T*A + beta*R, if TRANS = 'N', or
C                       alpha*A*T*T'*A' + beta*R, otherwise.
C
         IF ( REDUC .AND. N.GT.2 ) THEN
            CALL MB01YD( UPLO, NEGTRA, N, N, 1, ALPHA, BETA, A, LDA, R,
     $                   LDR, INFO2 )
         ELSE
            CALL DSYRK( UPLO, NEGTRA, N, N, ALPHA, A, LDA, BETA, R,
     $                  LDR )
         END IF
C
C        Compute (in R) -alpha*T'*T + R, if TRANS = 'N', or
C                       -alpha*T*T' + R, otherwise.
C
         CALL MB01YD( UPLO, NEGTRA, N, N, 0, -ALPHA, ONE, T, LDT, R,
     $                LDR, INFO2 )
C
      END IF
C
      RETURN
C *** Last line of MB01WD ***
      END


*
* --------------------------------------------------------------------------
* >>>
* NAME        : EXPINTEGRAL
* FILENAME    : EXPINTEGRAL.FOR
* DIRECTORY   : [REETZ.PROGLIB]
*
* PURPOSE     : Exponential-Integralfunction
* MODUL       : FORTRAN - Subroutine
* CALLING SEQ.: EXPINTEGRAL(x,n)
* INPUTS      : x Argument
*               n order (1,2)
* OUTPUTS     : Return-Value:
* AUTHOR      : Johannes Reetz
* DATE        :  9-OCT-1992 12:23:37.56
* <<<
* --------------------------------------------------------------------------
*

      REAL*4 FUNCTION expintegral(x,n)
      REAL*4    x
      REAL*8    y
      INTEGER*4 n
      REAL*8 A1,A2,A3,A4,B1,B2,B3,B4,C0,C1,C2,C3,C4,C5

C --- Coefficients for rational approx. 5.1.56
      PARAMETER (A1 =  8.5733287401)
      PARAMETER (A2 = 18.0590169730)
      PARAMETER (A3 =  8.6347608925)
      PARAMETER (A4 =  0.2677737343)
      PARAMETER (B1 =  9.5733223454)
      PARAMETER (B2 = 25.6329561486)
      PARAMETER (B3 = 21.0996530827)
      PARAMETER (B4 =  3.9584969228)

C --- Coefficients for rational approx. 5.1.53
      PARAMETER (C0 = -0.57721566)
      PARAMETER (C1 =  0.99999193)
      PARAMETER (C2 = -0.24991055)
      PARAMETER (C3 =  0.05519968)
      PARAMETER (C4 = -0.00976004)
      PARAMETER (C5 =  0.00107857)

C --- Polynomial approximation 5.1.53  (eps < 2.e-7)

      GOTO (100,200), n
      WRITE(*,*) 'ERROR in EXPINTEGRAL: Ordernumber of E2-function > 2'
      expintegral = 0.
      RETURN

100   CONTINUE
C --- Rational approximation 5.1.56    (eps < 2.e-8)
      IF (x.LT.1.) THEN
        IF (x.GT.0.) expintegral=C0+x*(C1+x*(C2+x*(C3+x*
     *                        (C4+x*C5))))-log(x)
      ELSE
        expintegral = exp(-x)*(A4+x*(A3+x*(A2+x*(A1+x)))) /
     *                   (x*(B4+x*(B3+x*(B2+x*(B1+x)))))
      ENDIF
      RETURN

200   CONTINUE
C --- Recurrence relation    5.1.14
      IF (x.LT.1) THEN
        expintegral = 1.
        IF (x.GT.0.) THEN
            expintegral = exp(-x)-x*(C0+x*
     *                      (C1+x*(C2+x*(C3+x*(C4+x*C5))))-log(x))
        ENDIF
      ELSE
C --- Rational approximation 5.1.56    (eps < 2.e-8)
          expintegral = exp(-x)*(1 - (A4+x*(A3+x*(A2+x*(A1+x)))) /
     *                          (B4+x*(B3+x*(B2+x*(B1+x))))  )
      ENDIF
      RETURN
      END


      subroutine ire_dgx(ctfmp,n_A,n_Axx,n_alpha,n_beta,n_divbeta,nm1_A,
     &np1_A,Nx,ht,hx,vee,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 hx
      real*8 vee
      real*8 ctfmp(Nx)
      real*8 n_A(Nx)
      real*8 n_Axx(Nx)
      real*8 n_alpha(Nx)
      real*8 n_beta(Nx)
      real*8 n_divbeta(Nx)
      real*8 nm1_A(Nx)
      real*8 np1_A(Nx)
      real*8 res
      real*8 qb
      res = 0.0D0
      do i=2, Nx-1, 1
      qb = -0.5000000000000000D0 * (nm1_A(i) - 0.1D1 * np1_A(i)) / ht +
     #0.2D1 * n_Axx(i) * n_alpha(i) + 0.6666666666666667D0 * n_A(i) * ve
     #e * n_divbeta(i) - 0.1D1 * (-0.1D1 * (n_beta(i - 1) - 0.1D1 * n_be
     #ta(i + 1)) / hx * n_A(i) + 0.5000000000000000D0 * n_beta(i) * (-0.
     #1D1 * n_A(i - 1) + n_A(i + 1)) / hx) / ctfmp(i)
      res = res + qb**2
      end do
      res = sqrt(res/(1*Nx))
      END


submodule(euler_interface_m) euler_prob_0026_m
    implicit none

contains

    module character(len=20) function euler0026()
        write (euler0026, "(i20)") answer(1000_int64)
    end function euler0026

    function answer(n) result(ret)
        use euler_primes_m, only: sieve_of_Eratosthenes
        implicit none

        integer(int64), intent(in) :: n
        integer(int64) :: ret, tmp, k, i
        logical, allocatable :: is_prime(:)

        call sieve_of_Eratosthenes(n, is_prime)
        tmp = 0_int64; k = 1_int64; ret = 0_int64
        do i = 7_int64, n
            if (is_prime(i)) then
                tmp = multiplicative_order(i, 10_int64)
                if (tmp > k) then
                    k = tmp
                    ret = i
                end if
            end if
        end do
    end function answer

    function multiplicative_order(n, m) result(ret)
        integer(int64), intent(in) :: n, m
        integer(int64) :: ret, res, k

        k = 1_int64; ret = 1_int64
        do
            res = mod(k*m, n)
            if (res /= 1_int64) then
                k = res
                ret = ret + 1_int64
            else
                exit
            end if
        end do
    end function multiplicative_order

end submodule euler_prob_0026_m


c *****************************************************
c    diskden.f
c 15 Sep, 2012   written by D. Kawata
c *****************************************************
c70*******************************************************************

      subroutine diskdeng(npg,mdisk,hd,zd0,flaggd
     &  ,flagflzd,Rflzd)
      include './define.f'
      integer npg,flaggd,flagflzd
      double precision rp,zp
      double precision mdisk,hd,zd0,rhoc,Rflzd,zdr
      integer i

      if(flaggd.le.1) then
c exp density profile
        do i=0,npg-1
          if(x_rzg(i).gt.0.0d0) then
            rp=x_rzg(i)
          else
            rp=10.0d0**lri_rzg
          endif
          if(z_rzg(i).gt.0.0d0) then
            zp=z_rzg(i)
          else
            zp=10.0d0**lzi_rzg
          endif
          if(flagflzd.eq.0) then
            rho_rzg(i)=(mdisk/(4.0d0*M_PI*zd0*(hd**2)))
     &        *(1.0d0/(dcosh(z_rzg(i)/zd0)**2))
     &        *dexp(-x_rzg(i)/hd)
          else
c flaring
            zdr=zd0*dexp(x_rzg(i)/Rflzd)
            rho_rzg(i)=(mdisk/(4.0d0*M_PI*zdr*(hd**2)))
     &        *(1.0d0/(dcosh(z_rzg(i)/zdr)**2))
     &        *dexp(-x_rzg(i)/hd)
          endif
          if(rho_rzg(i).lt.0.0d0) then
            write(6,*) x_rzg(i),z_rzg(i),rho_rzg(i)
          endif
        enddo
      else if(flaggd.eq.2) then
c constant density
        rhoc=mdisk/(M_PI*(hd**2)*(2.0d0*zd0))
        do i=0,npg-1
          if(x_rzg(i).gt.0.0d0) then
            rp=x_rzg(i)
          else
            rp=10.0d0**lri_rzg
          endif
          if(z_rzg(i).gt.0.0d0) then
            zp=z_rzg(i)
          else
            zp=10.0d0**lzi_rzg
          endif
          if(rp.lt.hd.and.zp.lt.zd0) then
            rho_rzg(i)=rhoc
          else
            rho_rzg(i)=0.0d0
          endif
        enddo
      else
c exp(-x/h-h/x) profile
        do i=0,npg-1
          if(x_rzg(i).gt.0.0d0) then
            rp=x_rzg(i)
          else
            rp=10.0d0**lri_rzg
          endif
          if(z_rzg(i).gt.0.0d0) then
            zp=z_rzg(i)
          else
            zp=10.0d0**lzi_rzg
          endif
          rho_rzg(i)=(mdisk/(3.18884*2.0d0*zd0*(hd**2)))
     &      *(1.0d0/(dcosh(z_rzg(i)/zd0)**2))
     &      *dexp(-x_rzg(i)/hd-hd/x_rzg(i))
          if(rho_rzg(i).lt.0.0d0) then
            write(6,*) x_rzg(i),z_rzg(i),rho_rzg(i)
          endif
        enddo
      endif

      return
      end


      subroutine setprob()
      implicit none

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision beta
      common /commannulus/ beta

      pi = 4.d0*atan(1.d0)
      pi2 = 2*pi

      open(10,file='setprob.data')
      read(10,*) beta
      close(10)

      end


program problem_3

!! how many trees would you encounter?

use aoc_utilities
use iso_fortran_env

implicit none

integer:: iunit, istat, n_lines, i, j, n_cols, col
character(len=1000) :: line
logical,dimension(:,:),allocatable :: data
integer,dimension(5),parameter :: right = [1,3,5,7,1]
integer,dimension(5),parameter :: down  = [1,1,1,1,2]
integer(int64) :: n_trees, product ! to avoid overflow

! read into a logical array (true=true)
open(newunit=iunit, file='input.txt', iostat=istat)
if (istat /= 0) error stop ' error reading file'
n_lines = number_of_lines_in_file(iunit)
do i = 1, n_lines
    read(iunit, '(A1000)', iostat=istat) line
    if (is_iostat_end(istat)) exit
    if (i==1) then
        n_cols = len_trim(line)
        allocate(data(n_lines, n_cols))
    end if
    do j = 1, n_cols
        data(i,j) = line(j:j) == '#'
    end do
end do

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

write(*,*) ''
write(*,*) 'part a:'

col = 0
n_trees = 0
do i = 1, n_lines
    if (data(i,col+1)) n_trees = n_trees + 1
    col = mod(col + 3, n_cols)
end do

write(*,*) 'n_trees = ', n_trees

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

write(*,*) ''
write(*,*) 'part b:'

product = 1
do j = 1, 5
    col = 0
    n_trees = 0
    do i = 1, n_lines, down(j)
        if (data(i,col+1)) n_trees = n_trees + 1
        col = mod(col + right(j), n_cols)
    end do
    product = product * n_trees
end do
write(*,*) 'product = ', product

end program problem_3


! $UWHPSC/codes/mpi/quadrature/quadrature_mod.f90

! Quadrature rules to approximate definite integrals.

module quadrature_mod

    use mpi

contains

subroutine simpson(f, a, b, n, integral)
    implicit none
    real(kind=8), intent(in) :: a,b
    integer, intent(in) :: n
    real(kind=8), intent(out) :: integral
    real(kind=8), external :: f
    ! local variables
    real(kind=8) :: xi, dx
    real(kind=8) :: int_proc, a_proc, b_proc, xi_proc
    integer :: numprocs, ierr,points_per_proc,proc_num
    integer :: i,istart,iend

    call MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)
    call MPI_COMM_RANK(MPI_COMM_WORLD, proc_num, ierr)

    ! Determine how many points to handle with each proc
    points_per_proc = (n + numprocs - 1)/numprocs
    if (proc_num == 0) then   ! Only one proc should print to avoid clutter
        print *, "points_per_proc = ", points_per_proc
    end if

    ! Determine start and end index for this proc's points
    istart = proc_num * points_per_proc + 1
    iend = min((proc_num + 1)*points_per_proc, n)

    dx = (b-a) / n
    integral = 0.d0

    a_proc = a + dx*(istart-1)
    b_proc = a + dx*iend
    int_proc = f(a_proc) + f(b_proc)

    ! Diagnostic: tell the user which points will be handled by which proc
    ! Note: print everything in a single print statement so all the
    ! info for a given process gets printed together.

    print 201, proc_num, istart, iend, a_proc, b_proc
201 format("Process ",i2," will take i = ",i9," through i = ",i9, /, &
           "   Corresponding to a_proc = ",e13.6," and b_proc = ",e13.6)

    do i=istart+1,iend
        xi_proc = a + dx*(i-1)
        int_proc = int_proc + 2.d0*f(xi_proc)
        enddo

    do i=istart,iend
        xi_proc = a + dx*(i-0.5d0)
        int_proc = int_proc + 4.d0*f(xi_proc)
        enddo

    call MPI_REDUCE(int_proc,integral,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
                        MPI_COMM_WORLD,ierr)

    if (proc_num == 0) then
        integral = dx*integral / 6.d0
    endif

    ! broadcast to all other processes so they all return the right thing:
    call MPI_BCAST(integral, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)

end subroutine simpson

end module quadrature_mod


use ArrayClass
implicit none

type(Array_) :: array1, array2, array3,array4

array1 = to_array([1,2,3],[4,5,6],[7,8,9],dtype="float")
array2 = to_array([0,0,1],dtype="float")
array3 = to_array("eye",ndim=3) ! identity matrix
array4 = to_array("random",ndim=3)

!check array
call print(array4)

! dot product
call print(dot_product(array1, array3) )

! matrix-vector multiplication
array1 = matmul(array1, array2)

array1 = array1%T() ! transpose

! or
!array1 = transpose(array1)

print *, array1%dtype
call print(array1)

print *, array4%dtype
call print(array4)

call array4%set(row=2,col=1, val=2.0d0)
print *, array4%dtype
call print(array4)

end


	SUBROUTINE LSFIT(Y,X,WT,N,A,B,RMS)
C
C	FIT Y = A*X + B, WITH REMOVAL OF BAD POINTS
C
	DIMENSION Y(1),X(1),WT(1),ERR(1000),WTS(1000)
C
	IF(N.GT.1000) STOP 'TOO MANY POINTS FOR LSFITER'
C
	DO J = 1,N
	  WTS(J) = WT(J)
	ENDDO
	NREMOVE = 0
	LIMIT = .1*N + .5
C
 100	SYY=0.
	SXY=0.
	SXX=0.
	SX=0.
	SY=0.
	SC=0.
	DO 1 J = 1,N
	   SYY=SYY+WT(J)*Y(J)**2
	   SXY=SXY+WT(J)*X(J)*Y(J)
	   SXX=SXX+WT(J)*X(J)**2
	   SX=SX+WT(J)*X(J)
	   SY=SY+WT(J)*Y(J)
	   SC=SC+WT(J)
 1	CONTINUE
	A=0.
	B=0.
	DEN=SXX*SC-SX*SX
	IF(DEN.EQ.0.) TYPE 101
	IF(DEN.EQ.0.) RETURN
	A=(SXY*SC-SY*SX)/DEN
	B=(SXX*SY-SX*SXY)/DEN
	SUMSQ=SYY+SXX*A**2+SC*B**2-2.*SXY*A-2.*SY*B+2.*SX*A*B
	SM=SUMSQ/SC
	RMS=SQRT(AMAX1(SM,0.))
C
C	NOW FIND LARGE ERRORS, AND REMOVE POINTS, ONE (LARGEST) AT A TIME
C		 IF MORE THAN 4 SIGMA, BUT LIMIT TO 10% OF POINTS
C
	ERRMAX = 0.
	max=1
	DO J = 1,N
	  ERR(J) = Y(J) - A*X(J) - B
	  IF(ABS(WT(J)*ERR(J)).GT.ERRMAX) THEN
	    ERRMAX = ABS(WT(J)*ERR(J))
	    MAX = J
	  ENDIF
	ENDDO
	IF(ERRMAX.GE.4.*RMS) THEN
	  WT(MAX) = 0.
	  NREMOVE = NREMOVE+1
	  PRINT*,'REMOVE, N,Y,X',MAX,Y(MAX),X(MAX)
	  IF(NREMOVE.LE.LIMIT) GO TO 100
	ENDIF
C
C	RESTORE WT
C
	DO J = 1,N
	  WT(J) = WTS(J)
	ENDDO
C
	RETURN
C
C
 101	FORMAT(' VANISHING DETERMINANT IN LSFIT')
	END