!*****************************************************************************************
!> author: Jacob Williams
!
!  Geodesy routines.

    module geodesy_module

    use kind_module,    only: wp

    implicit none

    private

    public :: heikkinen
    public :: olson
    public :: direct
    public :: inverse
    public :: geodetic_to_cartesian
    public :: great_circle_distance
    public :: geocentric_radius

    public :: direct_inverse_test

    contains
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!
!  Heikkinen routine for cartesian to geodetic transformation
!
!# References
!  1. M. Heikkinen, "Geschlossene formeln zur berechnung raumlicher
!     geodatischer koordinaten aus rechtwinkligen Koordinaten".
!     Z. Ermess., 107 (1982), 207-211 (in German).
!  2. E. D. Kaplan, "Understanding GPS: Principles and Applications",
!     Artech House, 1996.

    pure subroutine heikkinen(rvec, a, b, h, lon, lat)

    implicit none

    real(wp),dimension(3),intent(in) :: rvec  !! position vector [km]
    real(wp),intent(in)  :: a                 !! geoid semimajor axis [km]
    real(wp),intent(in)  :: b                 !! geoid semiminor axis [km]
    real(wp),intent(out) :: h                 !! geodetic altitude [km]
    real(wp),intent(out) :: lon               !! longitude [rad]
    real(wp),intent(out) :: lat               !! geodetic latitude [rad]

    real(wp) :: f,e_2,ep,r,e2,ff,g,c,s,pp,q,r0,u,v,z0,x,y,z,z2,r2,tmp,a2,b2

    x   = rvec(1)
    y   = rvec(2)
    z   = rvec(3)
    a2  = a*a
    b2  = b*b
    f   = (a-b)/a
    e_2 = (2.0_wp*f-f*f)
    ep  = sqrt(a2/b2 - 1.0_wp)
    z2  = z*z
    r   = sqrt(x**2 + y**2)
    r2  = r*r
    e2  = a2 - b2
    ff  = 54.0_wp * b2 * z2
    g   = r2 + (1.0_wp - e_2)*z2 - e_2*e2
    c   = e_2**2 * ff * r2 / g**3
    s   = (1.0_wp + c + sqrt(c**2 + 2.0_wp*c))**(1.0_wp/3.0_wp)
    pp  = ff / ( 3.0_wp*(s + 1.0_wp/s + 1.0_wp)**2 * g**2 )
    q   = sqrt( 1.0_wp + 2.0_wp*e_2**2 * pp )
    r0  = -pp*e_2*r/(1.0_wp+q) + &
            sqrt( max(0.0_wp, 1.0_wp/2.0_wp * a2 * (1.0_wp + 1.0_wp/q) - &
                ( pp*(1.0_wp-e_2)*z2 )/(q*(1.0_wp+q)) - &
                1.0_wp/2.0_wp * pp * r2) )
    u   = sqrt( (r - e_2*r0)**2 + z2 )
    v   = sqrt( (r - e_2*r0)**2 + (1.0_wp - e_2)*z2 )
    z0  = b**2 * z / (a*v)

    h   = u*(1.0_wp - b2/(a*v) )
    lat = atan2( (z + ep**2*z0), r )
    lon = atan2( y, x )

    end subroutine heikkinen
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!
!  Olson routine for cartesian to geodetic transformation.
!
!# References
!  1. Olson, D. K., Converting Earth-Centered, Earth-Fixed Coordinates to
!     Geodetic Coordinates, IEEE Transactions on Aerospace and Electronic
!     Systems, 32 (1996) 473-476.

    pure subroutine olson(rvec, a, b, h, long, lat)

    implicit none

    real(wp),dimension(3),intent(in) :: rvec !!position vector [km]
    real(wp),intent(in)  :: a                !!geoid semimajor axis [km]
    real(wp),intent(in)  :: b                !!geoid semiminor axis [km]
    real(wp),intent(out) :: h                !!geodetic altitude [km]
    real(wp),intent(out) :: long             !!longitude [rad]
    real(wp),intent(out) :: lat              !!geodetic latitude [rad]

    real(wp) :: f,x,y,z,e2,a1,a2,a3,a4,a5,a6,w,zp,&
                w2,r2,r,s2,c2,u,v,s,ss,c,g,rg,rf,m,p,z2

    x  = rvec(1)
    y  = rvec(2)
    z  = rvec(3)
    f  = (a-b)/a
    e2 = f * (2.0_wp - f)
    a1 = a * e2
    a2 = a1 * a1
    a3 = a1 * e2 / 2.0_wp
    a4 = 2.5_wp * a2
    a5 = a1 + a3
    a6 = 1.0_wp - e2
    zp = abs(z)
    w2 = x*x + y*y
    w  = sqrt(w2)
    z2 = z * z
    r2 = z2 + w2
    r  = sqrt(r2)

    if (r < 100.0_wp) then

        lat = 0.0_wp
        long = 0.0_wp
        h = -1.0e7_wp

    else

        s2 = z2 / r2
        c2 = w2 / r2
        u  = a2 / r
        v  = a3 - a4 / r

        if (c2 > 0.3_wp) then
            s = (zp / r) * (1.0_wp + c2 * (a1 + u + s2 * v) / r)
            lat = asin(s)
            ss = s * s
            c = sqrt(1.0_wp - ss)
        else
            c = (w / r) * (1.0_wp - s2 * (a5 - u - c2 * v) / r)
            lat = acos(c)
            ss = 1.0_wp - c * c
            s = sqrt(ss)
        end if

        g   = 1.0_wp - e2 * ss
        rg  = a / sqrt(g)
        rf  = a6 * rg
        u   = w - rg * c
        v   = zp - rf * s
        f   = c * u + s * v
        m   = c * v - s * u
        p   = m / (rf / g + f)
        lat = lat + p
        if (z < 0.0_wp) lat = -lat
        h = f + m * p / 2.0_wp
        long = atan2( y, x )

    end if

    end subroutine olson
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!
!  Solve the "direct" geodetic problem: given the latitude and longitude of one
!  point and the azimuth and distance to a second point, determine the latitude
!  and longitude of that second point.  The solution is obtained using the
!  algorithm by Vincenty.
!
!# References
!  1. T. Vincenty, "[Direct and Inverse Solutions of Geodesics on the
!     Ellipsoid with Application of Nested Equations](http://www.ngs.noaa.gov/PUBS_LIB/inverse.pdf)",
!     Survey Review XXII. 176, April 1975.
!  2. [PC Software Download - INVERSE and FORWARD](http://www.ngs.noaa.gov/PC_PROD/Inv_Fwd/),
!     National Geodetic Survey. Version 3.0 (November, 2012).

    subroutine direct(a,f,glat1,glon1,faz,s,glat2,glon2,baz)

    implicit none

    real(wp),intent(in)  :: a        !! semimajor axis of ellipsoid [m]
    real(wp),intent(in)  :: f        !! flattening of ellipsoid [-]
    real(wp),intent(in)  :: glat1    !! latitude of 1 [rad]
    real(wp),intent(in)  :: glon1    !! longitude of 1 [rad]
    real(wp),intent(in)  :: faz      !! forward azimuth 1->2 [rad]
    real(wp),intent(in)  :: s        !! distance from 1->2 [m]
    real(wp),intent(out) :: glat2    !! latitude of 2 [rad]
    real(wp),intent(out) :: glon2    !! longitude of 2 [rad]
    real(wp),intent(out) :: baz      !! back azimuth 2->1 [rad]

    real(wp) :: r,tu,sf,cf,cu,su,sa,csa,c2a,x,c,d,y,sy,cy,cz,e

    real(wp),parameter :: pi  = acos(-1.0_wp)
    real(wp),parameter :: eps = 0.5e-13_wp

    r  = 1.0_wp - f
    tu = r*sin(glat1)/cos(glat1)
    sf = sin(faz)
    cf = cos(faz)
    if ( cf/=0.0_wp ) then
        baz = atan2(tu,cf)*2.0_wp
    else
        baz = 0.0_wp
    end if
    cu  = 1.0_wp/sqrt(tu*tu+1.0_wp)
    su  = tu*cu
    sa  = cu*sf
    c2a = -sa*sa + 1.0_wp
    x   = sqrt((1.0_wp/r/r-1.0_wp)*c2a+1.0_wp) + 1.0_wp
    x   = (x-2.0_wp)/x
    c   = 1.0_wp - x
    c   = (x*x/4.0_wp+1.0_wp)/c
    d   = (0.375_wp*x*x-1.0_wp)*x
    tu  = s/r/a/c
    y   = tu
    do
        sy = sin(y)
        cy = cos(y)
        cz = cos(baz+y)
        e  = cz*cz*2.0_wp - 1.0_wp
        c  = y
        x  = e*cy
        y  = e + e - 1.0_wp
        y  = (((sy*sy*4.0_wp-3.0_wp)*y*cz*d/6.0_wp+x)*d/4.0_wp-cz)*sy*d + tu
        if ( abs(y-c)<=eps ) exit
    end do
    baz   = cu*cy*cf - su*sy
    c     = r*sqrt(sa*sa+baz*baz)
    d     = su*cy + cu*sy*cf
    glat2 = atan2(d,c)
    c     = cu*cy - su*sy*cf
    x     = atan2(sy*sf,c)
    c     = ((-3.0_wp*c2a+4.0_wp)*f+4.0_wp)*c2a*f/16.0_wp
    d     = ((e*cy*c+cz)*sy*c+y)*sa
    glon2 = glon1 + x - (1.0_wp-c)*d*f
    baz   = atan2(sa,baz) + pi

    end subroutine direct
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!
!  Geodetic latitude, longitude, and height to Cartesian position vector.
!
!# References
!  1. E. D. Kaplan, "Understanding GPS: Principles and Applications",
!     Artech House, 1996.

    subroutine geodetic_to_cartesian(a,b,glat,lon,h,r)

    implicit none

    real(wp),intent(in) :: a                !! geoid semimajor axis [km]
    real(wp),intent(in) :: b                !! geoid semiminor axis [km]
    real(wp),intent(in) :: glat             !! geodetic latitude [rad]
    real(wp),intent(in) :: lon              !! longitude [rad]
    real(wp),intent(in) :: h                !! geodetic altitude [km]
    real(wp),dimension(3),intent(out) :: r  !! Cartesian position vector [x,y,z]

    real(wp) :: e2,slat,clat,slon,clon,tlat,ome2,d,q,aod

    slat    = sin(glat)
    clat    = cos(glat)
    tlat    = tan(glat)
    slon    = sin(lon)
    clon    = cos(lon)
    e2      = 1.0_wp - (b*b)/(a*a)
    ome2    = 1.0_wp - e2
    d       = sqrt( 1.0_wp + ome2*tlat*tlat )
    q       = sqrt( 1.0_wp - e2*slat*slat   )
    aod     = a/d

    r(1) = aod*clon + h*clon*clat
    r(2) = aod*slon + h*slon*clat
    r(3) = a*ome2*slat/q + h*slat

    end subroutine geodetic_to_cartesian
!*****************************************************************************************

!*****************************************************************************************
!> author: Jacob Williams
!  date: 7/13/2014
!
!  Great circle distance on a spherical body, using the Vincenty algorithm.
!
!# References
!  * T. Vincenty, "[Direct and Inverse Solutions of Geodesics on the Ellipsoid
!    with Application of Nested Equations](http://www.ngs.noaa.gov/PUBS_LIB/inverse.pdf)",
!    Survey Review XXII. 176, April 1975.

    pure function great_circle_distance(r,long1,lat1,long2,lat2) result(d)

    implicit none

    real(wp)            :: d        !! great circle distance from 1 to 2 [km]
    real(wp),intent(in) :: r        !! radius of the body [km]
    real(wp),intent(in) :: long1    !! longitude of first site [rad]
    real(wp),intent(in) :: lat1     !! latitude of the first site [rad]
    real(wp),intent(in) :: long2    !! longitude of the second site [rad]
    real(wp),intent(in) :: lat2     !! latitude of the second site [rad]

    real(wp) :: c1,s1,c2,s2,dlon,clon,slon

    !Compute aux variables:
    c1    = cos(lat1)
    s1    = sin(lat1)
    c2    = cos(lat2)
    s2    = sin(lat2)
    dlon  = long1-long2
    clon  = cos(dlon)
    slon  = sin(dlon)

    d = r*atan2( sqrt((c2*slon)**2+(c1*s2-s1*c2*clon)**2), (s1*s2+c1*c2*clon) )

    end function great_circle_distance
!*****************************************************************************************

!*****************************************************************************************
!>
!  The distance from the center of a celestial body (e.g., the Earth) to a point
!  on the spheroid surface at a specified geodetic latitude.
!
!### Reference
!  * [Geocentric radius](https://en.wikipedia.org/wiki/Earth_radius#Geocentric_radius)

    pure function geocentric_radius(a,b,lat) result(r)

    use numbers_module, only: zero

    implicit none

    real(wp),intent(in) :: a    !! equatorial radius (km)
    real(wp),intent(in) :: b    !! polar radius of point (km)
    real(wp),intent(in) :: lat  !! geodetic latitude of point (rad)
    real(wp)            :: r    !! distance from center of body to point (km)

    !local variables:
    real(wp) :: num,den,cl2,sl2,a2,b2

    if (a==zero .and. b==zero) then
        r = zero
    else
        cl2 = cos(lat)**2
        sl2 = sin(lat)**2
        a2  = a*a
        b2  = b*b
        num = cl2 * a2**2 + sl2 * b2**2
        den = cl2 * a2    + sl2 * b2
        r   = sqrt(num/den)
    end if

    end function geocentric_radius
!*****************************************************************************************

!*****************************************************************************************
!>
!  INVERSE computes the geodetic azimuth and distance between two points,
!  given their geographic positions.
!
!  Version for long-line and antipodal cases.
!  Latitudes may be 90 degrees exactly.
!
!### Reference
!  * T. Vincenty, "[Direct and Inverse Solutions of Geodesics on the Ellipsoid
!    with Application of Nested Equations](http://www.ngs.noaa.gov/PUBS_LIB/inverse.pdf)",
!    Survey Review XXII. 176, April 1975.
!  * [inverse.for](http://www.ngs.noaa.gov/PC_PROD/Inv_Fwd/source/inverse.for)
!    Version 3.0 (November, 2012).
!
!### History
!  * Original programmed by thaddeus vincenty, 1975, 1976
!  * Removed back side solution option, debugged, revised -- 2011may01 -- dgm
!    this version of code is interim -- antipodal boundary needs work
!  * Jacob Williams, 1/25/2016 : refactored into modern Fortran.

    subroutine inverse(a,rf,b1,l1,b2,l2,faz,baz,s,it,sig,lam,kind)

    implicit none

    real(wp),intent(in)  :: a     !! Equatorial semimajor axis
    real(wp),intent(in)  :: rf    !! reciprocal flattening (1/f)
    real(wp),intent(in)  :: b1    !! latitude of point 1 (rad, positive north)
    real(wp),intent(in)  :: l1    !! longitude of point 1 (rad, positive east)
    real(wp),intent(in)  :: b2    !! latitude of point 2 (rad, positive north)
    real(wp),intent(in)  :: l2    !! longitude of point 2 (rad, positive east)
    real(wp),intent(out) :: faz   !! Forward azimuth (rad, clockwise from north)
    real(wp),intent(out) :: baz   !! Back azimuth (rad, clockwise from north)
    real(wp),intent(out) :: s     !! Ellipsoidal distance
    integer,intent(out)  :: it    !! iteration count
    real(wp),intent(out) :: sig   !! spherical distance on auxiliary sphere
    real(wp),intent(out) :: lam   !! longitude difference on auxiliary sphere
    integer,intent(out)  :: kind  !! solution flag: kind=1, long-line; kind=2, antipodal

    real(wp) :: beta1,beta2,biga,bigb,bige,bigf,boa,c,cosal2,coslam,&
                cossig,costm,costm2,cosu1,cosu2,d,dsig,ep2,l,prev,&
                sinal,sinlam,sinsig,sinu1,sinu2,tem1,tem2,temp,test,z

    real(wp),parameter :: pi     = acos(-1.0_wp)
    real(wp),parameter :: two_pi = 2.0_wp * pi
    real(wp),parameter :: tol    = 1.0e-14_wp   !! convergence tolerance
    real(wp),parameter :: eps    = 1.0e-15_wp   !! tolerance for zero

    boa = 1.0_wp - 1.0_wp/rf   ! b/a

    beta1 = atan(boa*tan(b1))  ! better reduced latitude
    sinu1 = sin(beta1)
    cosu1 = cos(beta1)
    beta2 = atan(boa*tan(b2))  ! better reduced latitude
    sinu2 = sin(beta2)
    cosu2 = cos(beta2)

    l = l2 - l1  ! longitude difference [-pi,pi]
    if ( l>pi ) l = l - two_pi
    if ( l<-pi ) l = l + two_pi
    prev = l
    test = l
    it   = 0
    kind = 1
    lam  = l

    longline : do  ! long-line loop (kind=1)

        sinlam = sin(lam)
        coslam = cos(lam)
        temp   = cosu1*sinu2 - sinu1*cosu2*coslam
        sinsig = sqrt((cosu2*sinlam)**2+temp**2)
        cossig = sinu1*sinu2 + cosu1*cosu2*coslam
        sig    = atan2(sinsig,cossig)
        if ( abs(sinsig)<eps ) then
            sinal = cosu1*cosu2*sinlam/sign(eps,sinsig)
        else
            sinal = cosu1*cosu2*sinlam/sinsig
        endif
        cosal2 = -sinal**2 + 1.0_wp
        if ( abs(cosal2)<eps ) then
            costm = -2.0_wp*(sinu1*sinu2/sign(eps,cosal2)) + cossig
        else
            costm = -2.0_wp*(sinu1*sinu2/cosal2) + cossig
        endif
        costm2 = costm*costm
        c = ((-3.0_wp*cosal2+4.0_wp)/rf+4.0_wp)*cosal2/rf/16.0_wp

        antipodal : do  ! antipodal loop (kind=2)

            it = it + 1
            d = (((2.0_wp*costm2-1.0_wp)*cossig*c+costm)*sinsig*c+sig)*(1.0_wp-c)/rf
            if ( kind==1 ) then
                lam = l + d*sinal
                if ( abs(lam-test)>=tol ) then
                    if ( abs(lam)>pi ) then
                        kind   = 2
                        lam    = pi
                        if ( l<0.0_wp ) lam = -lam
                        sinal  = 0.0_wp
                        cosal2 = 1.0_wp
                        test   = 2.0_wp
                        prev   = test
                        sig    = pi - abs(atan(sinu1/cosu1)+atan(sinu2/cosu2))
                        sinsig = sin(sig)
                        cossig = cos(sig)
                        c      = ((-3.0_wp*cosal2+4.0_wp)/rf+4.0_wp)*cosal2/rf/16.0_wp
                        if ( abs(sinal-prev)<tol ) exit longline
                        if ( abs(cosal2)<eps ) then
                            costm = -2.0_wp*(sinu1*sinu2/sign(eps,cosal2)) + cossig
                        else
                            costm = -2.0_wp*(sinu1*sinu2/cosal2) + cossig
                        endif
                        costm2 = costm*costm
                        cycle antipodal
                    endif
                    if ( ((lam-test)*(test-prev))<0.0_wp .and. it>5 ) &
                         lam = (2.0_wp*lam+3.0_wp*test+prev)/6.0_wp  ! refined converge.
                    prev = test
                    test = lam
                    cycle longline
                endif
            else
                sinal  = (lam-l)/d
                if ( ((sinal-test)*(test-prev))<0.0_wp .and. it>5 ) &
                       sinal = (2.0_wp*sinal+3.0_wp*test+prev)/6.0_wp  ! refined converge.
                prev   = test
                test   = sinal
                cosal2 = -sinal**2 + 1.0_wp
                sinlam = sinal*sinsig/(cosu1*cosu2)
                coslam = -sqrt(abs(-sinlam**2+1.0_wp))
                lam    = atan2(sinlam,coslam)
                temp   = cosu1*sinu2 - sinu1*cosu2*coslam
                sinsig = sqrt((cosu2*sinlam)**2+temp**2)
                cossig = sinu1*sinu2 + cosu1*cosu2*coslam
                sig    = atan2(sinsig,cossig)
                c      = ((-3.0_wp*cosal2+4.0_wp)/rf+4.0_wp)*cosal2/rf/16.0_wp
                if ( abs(sinal-prev)>=tol ) then
                    if ( abs(cosal2)<eps ) then
                        costm = -2.0_wp*(sinu1*sinu2/sign(eps,cosal2)) + cossig
                    else
                        costm = -2.0_wp*(sinu1*sinu2/cosal2) + cossig
                    endif
                    costm2 = costm*costm
                    cycle antipodal
                endif
            endif

            exit longline  !finished

        end do antipodal

    end do longline

    ! convergence

    if ( kind==2 ) then  ! antipodal
        faz  = sinal/cosu1
        baz  = sqrt(-faz**2+1.0_wp)
        if ( temp<0.0_wp ) baz = -baz
        faz  = atan2(faz,baz)
        tem1 = -sinal
        tem2 = sinu1*sinsig - cosu1*cossig*baz
        baz  = atan2(tem1,tem2)
    else  ! long-line
        tem1 = cosu2*sinlam
        tem2 = cosu1*sinu2 - sinu1*cosu2*coslam
        faz  = atan2(tem1,tem2)
        tem1 = -cosu1*sinlam
        tem2 = sinu1*cosu2 - cosu1*sinu2*coslam
        baz  = atan2(tem1,tem2)
    endif
    if ( faz<0.0_wp ) faz = faz + two_pi
    if ( baz<0.0_wp ) baz = baz + two_pi

    ! helmert 1880 from vincenty "geodetic inverse solution between antipodal points"

    ep2  = 1.0_wp/(boa*boa) - 1.0_wp
    bige = sqrt(1.0_wp+ep2*cosal2)
    bigf = (bige-1.0_wp)/(bige+1.0_wp)
    biga = (1.0_wp+bigf*bigf/4.0_wp)/(1.0_wp-bigf)
    bigb = bigf*(1.0_wp-0.375_wp*bigf*bigf)
    z    = bigb/6.0_wp*costm*(-3.0_wp+4.0_wp*sinsig**2)*(-3.0_wp+4.0_wp*costm2)
    dsig = bigb*sinsig*(costm+bigb/4.0_wp*(cossig*(-1.0_wp+2.0_wp*costm2)-z))
    s    = (boa*a)*biga*(sig-dsig)

    end subroutine inverse
!*****************************************************************************************

!*****************************************************************************************
!>
!  Unit test for the [[direct]] and [[inverse]] geodetic routines.

    subroutine direct_inverse_test()

    implicit none

    !Ellipsoid : GRS80 / WGS84 (NAD83)
    real(wp),parameter :: a  = 6378137.0000_wp      !! Equatorial radius
    real(wp),parameter :: rf = 298.25722210088_wp   !! Inverse flattening
    real(wp),parameter :: f  = 1.0_wp / rf          !! flattening

    real(wp) :: glat1,glon1,glat2,glon2,faz,baz,s,sig,lam,glat2_,glon2_,baz_
    integer :: it, kind

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

    !specify two points:
    glat1 = 0.523599_wp
    glon1 = 1.74533_wp
    glat2 = 0.698132_wp
    glon2 = 2.0944_wp

    call inverse(a,rf,glat1,glon1,glat2,glon2,faz,baz,s,it,sig,lam,kind)
    call direct(a,f,glat1,glon1,faz,s,glat2_,glon2_,baz_)

    write(*,*) 'lat error: ', glat2_ - glat2
    write(*,*) 'lon error: ', glon2_ - glon2
    write(*,*) 'baz error: ', baz_ - baz

    end subroutine direct_inverse_test
!*****************************************************************************************

!*****************************************************************************************
    end module geodesy_module
!*****************************************************************************************


!-- sampleFilt.f90
!-- 4 Mar 92, Richard Maine: Version 1.0.

module gd_filter1

  !-- Sample getData 3rd order lowpass filter module.
  !-- 22 Mar 91, Richard Maine.

  use precision
  use sysdep_io

  implicit none
  private

  !-- Name used to identify this filter.
  character, public :: filter_name*(16)='low3Filt'

  type filter_type
    logical :: is_open   !-- Is this filter open or free?
    real(r_kind) :: eat, gain1     !-- Coefficients for 1st order lowpass.
    real(r_kind) :: c1, c2, gain2  !-- Coefficients for 2nd order lowpass.
    real(r_kind), pointer :: u1(:)         !-- Prev input.
    real(r_kind), pointer :: z1(:), z2(:)  !-- Prev and 2 prev output.
    real(r_kind), pointer :: y0(:), y1(:), y2(:)
         !-- Current, prev, and 2 prev intermediate state.
  end type
  type filter_ptr_type
    type(filter_type), pointer :: filter
  end type

  type(filter_ptr_type) :: filter_ptr  !-- Scratch use only.  Not saved.

  !-- Public procedures.
  public open_filter, close_filter, do_filter

contains

  subroutine open_filter (filter_handle, filter_dt, filter_parameters, &
       n_signals, filter_description, error)

    !-- Open the filter connection.
    !-- 22 Mar 90, Richard Maine.

    !-------------------- interface.
    integer, pointer :: filter_handle(:)
         !-- A handle used to distinguish multiple opens.
         !-- May be ignored if this filter does not support multiple opens.
         !-- Otherwise, may be allocated to any required size and used
         !-- to save data between calls.  Initialized to null on entry.
         !-- For this filter, it stores a pointer to the filter structure.
    real(r_kind), intent(in) :: filter_dt
         !-- Sample interval for the filter.
    real(r_kind), intent(in) :: filter_parameters(:)
         !-- Interpretation of the parameters depends on the
         !-- filter routines.  The most common parameter will
         !-- probably be filter break frequency.
         !-- This module expects 1 parameter, the break frequency in Hz.
    integer, intent(in) :: n_signals
         !-- Number of signals using this filter.
         !-- This count includes all signals defined to use the filter
         !-- regardless of whether the signals are activated or not.
         !-- The number of active signals using the filter may be
         !-- smaller, but will not exceed n_signals.
    character*(*), intent(out) :: filter_description
         !-- Description (typically up to 80 characters) of this filter.
    logical, intent(out) :: error  !-- True if an error occurs.

    !-------------------- local.
    integer :: iostat, handle_size
    type(filter_type), pointer :: f
    real(r_kind) :: freq, w_dt, eabt
    real(r_kind), parameter :: pi=3.14159265358979_r_kind

    !-------------------- executable code.

    !-- Allocate a filter.
    nullify(f)
    allocate(f, stat=iostat)
    if (iostat /= 0) goto 8000
    nullify(f%u1, f%y0, f%y1, f%y2, f%z1, f%z2)
    handle_size = size(transfer(filter_ptr,filter_handle))
    allocate(filter_handle(handle_size), stat=iostat)
    if (iostat /= 0)  goto 8000
    filter_ptr%filter => f
    filter_handle = transfer(filter_ptr,filter_handle)

    if (size(filter_parameters) < 1) then
       call write_error_msg('Too few filter parameters.')
       goto 8000
    end if

    filter_description = &
       'Sample 3rd order lowpass filter.  Version 4.0, 7 Nov 91.'

    !-- Compute filter coefficients.
    freq = filter_parameters(1)
    w_dt = filter_dt*freq*2.*pi
    f%eat = exp(-w_dt)
    f%gain1 =.5*(1. - f%eat)
    eabt = exp(-sqrt(.75_r_kind)*w_dt)
    f%c1 = 2.*eabt*cos(.5*w_dt)
    f%c2 = -(eabt**2)
    f%gain2 = .25*(1. - f%c1 - f%c2)

    !-- Normal return.
    error = .false.
    return

    !-- Error exit.
    8000 continue
    if (associated(f)) deallocate(f)
    error = .true.
    return
  end subroutine open_filter

  subroutine close_filter (filter_handle)

    !-- Close the filter connection.
    !-- 22 Mar 90, Richard Maine.

    !-------------------- interface.
    integer, pointer :: filter_handle(:)  !-- See open_filter.

    !-------------------- local.
    type(filter_type), pointer :: filter

    !-------------------- executable code.

    filter_ptr = transfer(filter_handle, filter_ptr)
    filter => filter_ptr%filter

    call release_filter_states(filter)
    return
  end subroutine close_filter

  subroutine release_filter_states (filter)

    !-- Deallocate the filter state buffers.
    !-- 22 Mar 90, Richard Maine.

    !-------------------- interface.
    type(filter_type), intent(inout) :: filter

    !-------------------- executable code.

    if (associated(filter%u1)) deallocate(filter%u1)
    if (associated(filter%z1)) deallocate(filter%z1)
    if (associated(filter%z2)) deallocate(filter%z2)
    if (associated(filter%y0)) deallocate(filter%y0)
    if (associated(filter%y1)) deallocate(filter%y1)
    if (associated(filter%y2)) deallocate(filter%y2)
    return
  end subroutine release_filter_states

  subroutine do_filter (filter_handle, reset, time, input_data, output_data, &
       error)

    !-- Compute filter for one time frame.
    !-- 22 Mar 90, Richard Maine.

    !-------------------- interface.
    integer, pointer :: filter_handle(:)  !-- See open_filter.
    logical, intent(in) :: reset
         !-- Should the filter be reset?
         !-- True on first frame of a time interval.
         !-- When this is true, internal buffers based on the size of
         !-- input_data and output_data are allocated or reallocated.
    real(r_kind), intent(in) :: time
    real(r_kind), intent(in) :: input_data(:)
    real(r_kind), intent(out) :: output_data(:)
         !-- Note that the size of input_data and output_data may be
         !-- less than the value of n_signals from open_gd_filter.
         !-- A new size is established whenever reset is true.
    logical, intent(inout) :: error
         !-- True if an error occurs.  Initialized to false on entry.

    !-------------------- local.
    type(filter_type), pointer :: f
    integer :: iostat, n

    !-------------------- executable code.

    filter_ptr = transfer(filter_handle, filter_ptr)
    f => filter_ptr%filter

    !-- Allocate and initialize filter state vectors.
    if (reset) then
      call release_filter_states(f)
      n = size(input_data)
      allocate(f%u1(n), f%y0(n), f%y1(n), f%y2(n), f%z1(n), f%z2(n), &
           stat=iostat)
      error = iostat /= 0
      if (error) return

      f%u1 = input_data
      f%y0 = input_data
      f%y1 = input_data
      f%y2 = input_data
      f%z1 = input_data
      f%z2 = input_data
      output_data = input_data

    !-- filter.
    !-- We currently ignore time and just assume that dt is constant.
    else
      !-- First order lowpass.
      f%y0 = f%eat*f%y1 + f%gain1*(input_data + f%u1)

      !-- Second order lowpass.
      output_data = f%c1*f%z1 + f%c2*f%z2 + f%gain2*(f%y0 + 2.*f%y1 + f%y2)

      !-- time-shift state vectors.
      f%u1 = input_data
      f%y2 = f%y1
      f%y1 = f%y0
      f%z2 = f%z1
      f%z1 = output_data
    end if
    return
  end subroutine do_filter

end module gd_filter1

module gd_filter2

  !-- Sample getData notch filter module.
  !-- 22 Mar 91, Richard Maine.

  use precision
  use sysdep_io

  implicit none
  private

  !-- Name used to identify this filter.
  character, public :: filter_name*(16)='notchFilt'

  type filter_type
    logical :: is_open   !-- Is this filter open or free?
    real(r_kind) :: c1, c2, b1, gain  !-- Filter coefficients.
    real(r_kind), pointer :: u1(:), u2(:)  !-- Prev and 2 prev input.
    real(r_kind), pointer :: z1(:), z2(:)  !-- Prev and 2 prev output.
  end type
  type filter_ptr_type
    type(filter_type), pointer :: filter
  end type

  type(filter_ptr_type) :: filter_ptr  !-- Scratch use only.  Not saved.

  !-- Public procedures.
  public open_filter, close_filter, do_filter

contains

  subroutine open_filter (filter_handle, filter_dt, filter_parameters, &
       n_signals, filter_description, error)

    !-- Open the filter connection.
    !-- 22 Mar 90, Richard Maine.

    !-------------------- interface.
    integer, pointer :: filter_handle(:)
         !-- A handle used to distinguish multiple opens.
         !-- May be ignored if this filter does not support multiple opens.
         !-- Otherwise, may be allocated to any required size and used
         !-- to save data between calls.  Initialized to null on entry.
         !-- For this filter, it stores a pointer to the filter structure.
    real(r_kind), intent(in) :: filter_dt
         !-- Sample interval for the filter.
    real(r_kind), intent(in) :: filter_parameters(:)
         !-- Interpretation of the parameters depends on the
         !-- filter routines.  The most common parameter will
         !-- probably be filter break frequency.
         !-- This module expects 1 parameter, the notch frequency in Hz.
    integer, intent(in) :: n_signals
         !-- Number of signals using this filter.
         !-- This count includes all signals defined to use the filter
         !-- regardless of whether the signals are activated or not.
         !-- The number of active signals using the filter may be
         !-- smaller, but will not exceed n_signals.
    character*(*), intent(out) :: filter_description
         !-- Description (typically up to 80 characters) of this filter.
    logical, intent(out) :: error  !-- True if an error occurs.

    !-------------------- local.
    integer :: iostat, handle_size
    type(filter_type), pointer :: f
    real(r_kind) :: freq, w_dt, w2_dt
    real(r_kind), parameter :: pi=3.14159265358979_r_kind

    !-------------------- executable code.

    !-- Allocate a filter.
    nullify(f)
    allocate(f, stat=iostat)
    if (iostat /= 0) goto 8000
    nullify(f%u1, f%u2, f%z1, f%z2)
    handle_size = size(transfer(filter_ptr,filter_handle))
    allocate(filter_handle(handle_size), stat=iostat)
    if (iostat /= 0)  goto 8000
    filter_ptr%filter => f
    filter_handle = transfer(filter_ptr,filter_handle)

    if (size(filter_parameters) < 1) then
       call write_error_msg('Too few filter parameters.')
       goto 8000
    end if

    filter_description = 'Sample notch filter.  Version 4.0, 22 Mar 91.'

    !-- Compute filter coefficients.
    freq = filter_parameters(1)
    w_dt = filter_dt*freq*2.*pi
    f%b1 = -2.*cos(w_dt)
    w2_dt = w_dt*sqrt(2._r_kind)
    f%c1 = 2.*exp(-w2_dt)*cos(w2_dt)
    f%c2 = -exp(-2.*w2_dt)
    f%gain = (1. - f%c1 - f%c2)/(2. + f%b1)

    !-- Normal return.
    error = .false.
    return

    !-- Error exit.
    8000 continue
    if (associated(f)) deallocate(f)
    error = .true.
    return
  end subroutine open_filter

  subroutine close_filter (filter_handle)

    !-- Close the filter connection.
    !-- 22 Mar 90, Richard Maine.

    !-------------------- interface.
    integer, pointer :: filter_handle(:)  !-- See open_filter.

    !-------------------- local.
    type(filter_type), pointer :: filter

    !-------------------- executable code.

    filter_ptr = transfer(filter_handle, filter_ptr)
    filter => filter_ptr%filter

    call release_filter_states(filter)
    return
  end subroutine close_filter

  subroutine release_filter_states (filter)

    !-- Deallocate the filter state buffers.
    !-- 22 Mar 90, Richard Maine.

    !-------------------- interface.
    type(filter_type), intent(inout) :: filter

    !-------------------- executable code.

    if (associated(filter%u1)) deallocate(filter%u1)
    if (associated(filter%u2)) deallocate(filter%u2)
    if (associated(filter%z1)) deallocate(filter%z1)
    if (associated(filter%z2)) deallocate(filter%z2)
    return
  end subroutine release_filter_states

  subroutine do_filter (filter_handle, reset, time, input_data, output_data, &
       error)

    !-- Compute filter for one time frame.
    !-- 22 Mar 90, Richard Maine.

    !-------------------- interface.
    integer, pointer :: filter_handle(:)  !-- See open_filter.
    logical, intent(in) :: reset
         !-- Should the filter be reset?
         !-- True on first frame of a time interval.
         !-- When this is true, internal buffers based on the size of
         !-- input_data and output_data are allocated or reallocated.
    real(r_kind), intent(in) :: time
    real(r_kind), intent(in) :: input_data(:)
    real(r_kind), intent(out) :: output_data(:)
         !-- Note that the size of input_data and output_data may be
         !-- less than the value of n_signals from open_gd_filter.
         !-- A new size is established whenever reset is true.
    logical, intent(inout) :: error
         !-- True if an error occurs.  Initialized to false on entry.

    !-------------------- local.
    type(filter_type), pointer :: f
    integer :: iostat, n

    !-------------------- executable code.

    filter_ptr = transfer(filter_handle, filter_ptr)
    f => filter_ptr%filter

    !-- Allocate and initialize filter state vectors.
    if (reset) then
      call release_filter_states(f)
      n = size(input_data)
      allocate(f%u1(n), f%u2(n), f%z1(n), f%z2(n), stat=iostat)
      error = iostat /= 0
      if (error) return

      f%u1 = input_data
      f%u2 = input_data
      f%z1 = input_data
      f%z2 = input_data
      output_data = input_data

    !-- filter.
    !-- We currently ignore time and just assume that dt is constant.
    else
      output_data = f%c1*f%z1 + f%c2*f%z2 + &
           f%gain*(input_data + f%b1*f%u1 + f%u2)

      !-- time-shift state vectors.
      f%u2 = f%u1
      f%u1 = input_data
      f%z2 = f%z1
      f%z1 = output_data
    end if
    return
  end subroutine do_filter

end module gd_filter2


program test

! forces declaration of all variables
implicit none

! strings are arrays of chars like in C
character (len =20) :: name

! constant float
real, parameter :: PI = 3.14

! float; only six digits of precision
real :: num1 = 0.0 , num2 = 0.1

! float; 15 digits of precision; d+0 necessary
double precision :: numDP = 1.11111111111d+0

! integer
integer :: numInt = 1

! booleans
logical :: isReady = .true.

! complex numbers
complex :: numComplex = (2.0, 4.0)

print *, "biggest real = ", huge(num1), " ; smallest real = ", tiny(num2)
print *, "biggest int = ", huge(numInt)

print *, "Integer", kind(numInt)
print *, "Double", kind(numDP)
print *, "Complex", kind(numComplex)
print *, "Boolean", kind(isReady)
print *, "String", kind(name)

end program test


    program demo_nint
    implicit none
    integer,parameter :: dp=kind(0.0d0)
    real              :: x4 = 1.234E0
    real(kind=dp)     :: x8 = 4.721_dp

    ! basic use
       print *, nint(x4), nint(x8),nint(-x8)
       ! elemental
       print *,nint([ &
       &  -2.7,  -2.5, -2.2, -2.0, -1.5, -1.0, -0.5, &
       &  0.0,   &
       &  +0.5,  +1.0, +1.5, +2.0, +2.2, +2.5, +2.7  ])

    ! issues
    ISSUES: block
    use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
    integer :: icheck
       ! make sure input is in range for the type returned
       write(*,*)'Range limits for typical KINDS:'
       write(*,'(1x,g0,1x,g0)')  &
       & int8,huge(0_int8),   &
       & int16,huge(0_int16), &
       & int32,huge(0_int32), &
       & int64,huge(0_int64)

       ! the standard does not require this to be an error ...
       x8=12345.67e15 ! too big of a number
       icheck=selected_int_kind(ceiling(log10(x8)))
       write(*,*)'Any KIND big enough? ICHECK=',icheck
       print *, 'These are all wrong answers for ',x8
       print *, nint(x8,kind=int8)
       print *, nint(x8,kind=int16)
       print *, nint(x8,kind=int32)
       print *, nint(x8,kind=int64)
    endblock ISSUES

    end program demo_nint


* FORTRAN test file to implement the DATA statement
* This file uses the DATA statement to assign arrays using implied DO loops

**********************************************************************
* Expected Output: A:
*                  1.0  3.0
*				   2.0  4.0
*
*			       B:
*			       1.1  2.1
*			       3.1  4.1
**********************************************************************

      PROGRAM MAIN

      IMPLICIT NONE

      REAL, DIMENSION(2,2) :: A
      REAL, DIMENSION(2,2) :: B

      INTEGER :: I, J

      DATA A /1.0, 2.0, 3.0, 4.0/
      DATA B(1,1) /1.1/, B(1,2) /2.1/, B(2,1), B(2,2) /3.1, 4.1/

      WRITE (*,12) 'A: '
      DO I = 1, 2
          WRITE (*,20) A(I,1), A(I,2)
      END DO

      WRITE (*,11)
      WRITE (*,12) 'B: '
      DO I = 1, 2
          WRITE (*,20) B(I,1), B(I,2)
      END DO

 11   FORMAT('')
 12   FORMAT(A)
 20   FORMAT(2(F3.1,2X))
 30   FORMAT(4(F3.1,2X))
 40   FORMAT(10(F3.1,2X))

      END PROGRAM MAIN


program test_rp1

    use rp1_driver, only: call_rp1

    implicit none

    integer, parameter :: meqn = 2
    integer, parameter :: mwaves = 2
    real(kind=8) ::   q_left(meqn)
    real(kind=8) ::   q_right(meqn)
    real(kind=8) ::    s(mwaves)
    real(kind=8) :: wave(meqn,   mwaves)
    real(kind=8) ::  apdq(meqn)
    real(kind=8) ::  amdq(meqn)
    integer :: i, m, mw

    real(kind=8) :: rho,bulk,cc,zz
    common /cparam/ rho,bulk,cc,zz
    rho = 1.d0
    bulk = 1.d0
    cc = sqrt(bulk/rho)
    zz = rho*cc

    write(6,61) meqn
 61 format('Need to input meqn = ',i3,'  values for each state')
    write(6,*) 'input q_left:'
    read(5,*) (q_left(i), i=1,meqn)
    write(6,*) 'input q_right:'
    read(5,*) (q_right(i), i=1,meqn)

    call call_rp1(meqn,mwaves,q_left,q_right,wave,s,amdq,apdq)

    print *, 'speeds:'
    write(6,60) (s(mw), mw=1,mwaves)
60  format(6d16.6)

    print *, 'waves:'
    do m=1,meqn
        write(6,60) (wave(m,mw), mw=1,mwaves)
        enddo

    print *, 'amdq and apdq:'
    do m=1,meqn
        write(6,60) amdq(m), apdq(m)
        enddo

end program test_rp1


#include "Config.fpp"

module mod_kmeans

 !===================================================================================85
 !---------------------------- DESCRIPTION ------------------------------------------85
 !
 !
 !
 !          Module  name:
 !                         'mod_kmeans'
 !
 !          Purpose:
 !                    This module is based on John Burkardt 'KMEANS' implementation
 !          History:
 !                        Date: 12-05-2018
 !                        Time: 16:06 GMT+2
 !
 !          Version:
 !
 !                      Major: 1
 !                      Minor: 0
 !                      Micro: 0
 !
 !          Author:
 !                  Bernard Gingold
 !
 !          References:
 !
 !                John Burkardt webpage
 !
 !
 !          E-mail:
 !
 !                      beniekg@gmail.com
 !==================================================================================85
    ! Tab:5 col - Type and etc.. definitions
    ! Tab:10,11 col - Type , function and subroutine code blocks.

    use module_kinds, only : I32P, R64P
    implicit none
    private

    !=====================================================59
    !  File and module information:
    !  version,creation and build date, author,description
    !=====================================================59

    ! Major version
    integer(I32P), parameter, public :: MOD_KMEANS_MAJOR = 1_I32P

    ! Minor version
    integer(I32P), parameter, public :: MOD_KMEANS_MINOR = 0_I32P

    ! Micro version
    integer(I32P), parameter, public :: MOD_KMEANS_MICRO = 0_I32P

    ! Module full version
    integer(I32P), parameter, public :: MOD_KMEANS_FULLVER = 1000_I32P*MOD_KMEANS_MAJOR + &
                                                             100_I32P*MOD_KMEANS_MINOR  + &
                                                             10_I32P*MOD_KMEANS_MICRO
    ! Module creation date
    character(*),  parameter, public :: MOD_KMEANS_CREATE_DATE = "12-05-2018 16:19 +00200 (SAT 12 MAY 2018 GMT+2)"

    ! Module build date ( should be set after successful compilation date/time)
    character(*),  parameter, public :: MOD_KMEANS_BUILD_DATE = " "

    ! Module author info
    character(*),  parameter, public :: MOD_KMEANS_AUTHOR = "Original author: John Burkardt, modified by: Bernard Gingold, e-mail: beniekg@gmail.com "

    ! Module short description
    character(*),  parameter, public :: MOD_KMEANS_DESCRIPT = "Fortran 2003 version of John Burkardt 'KMEANS' library."

    !================================
    ! type: Kmeans_t
    !================================
    type, public :: Kmeans_t

          private
          !  the number of spatial dimensions.
          integer(I32P) :: m_dim_num
          !  the number of signal samples (re,im) components
          integer(I32P) :: m_samples_num
          ! the number of clusters.
          integer(I32P) :: m_cluster_num
          !  the maximum number of iterations.
          integer(I32P) :: m_iter_max
          !  the number of iterations taken.
          integer(I32P) :: m_iter_num
          !  a seed for the random number generator.
          integer(I32P) :: m_seed

          !     On input, the user
		  !		may specify an initial cluster for each point, or leave all entrie of
		  !		CLUSTER set to 0.  On output, CLUSTER contains the index of the
		  !		cluster to which each data point belongs.

          integer(I32P), allocatable, dimension(:),   public :: m_cluster
          !   the coordinates of the cluster centers.
          real(R64P),    allocatable, dimension(:,:), public :: m_cluster_center
          !   the number of
          !	  points assigned to each cluster.
          integer(I32P), allocatable, dimension(:),   public :: m_cluster_population
          !   the energy of   the clusters.
		  real(R64P),    allocatable, dimension(:),   public :: m_cluster_energy

          contains

          !========================================
          !    Getter procedures
          !========================================

          procedure, pass(this), public :: get_dim_num

          procedure, pass(this), public :: get_samples_num

          procedure, pass(this), public :: get_cluster_num

          procedure, pass(this), public :: get_iter_max

          procedure, pass(this), public :: get_iter_num

          procedure, pass(this), public :: get_seed

          !========================================
          !    Read/write procedures
          !========================================

          procedure, nopass, public :: write_state

          procedure, nopass, public :: read_state

          !=======================================
          !  Class helper procedures
          !=======================================

          procedure, pass(this), public ::  dbg_info

          !============================================
          !  Computational procedures
          !============================================

          procedure, pass(this), public :: compute_hmeans01

          procedure, pass(this), public :: compute_hmeans02

          procedure, pass(this), public :: compute_kmeans01

          procedure, pass(this), public :: compute_kmeans02

          procedure, pass(this), public :: compute_kmeans03

          procedure, pass(this), public :: compute_hmeans01_kmeans01

          procedure, pass(this), public :: compute_hmeans01_kmeans02

          procedure, pass(this), public :: compute_hmeans01_kmeans03

    end type Kmeans_t

          interface Kmeans_t

            procedure :: constructor

          end interface Kmeans_t

    contains

    type(Kmeans_t) function constructor(dim_num,samples_num,cluster_num,iter_max,seed, &
                                        logging,verbose,fname,append  )
          use mod_print_error, only : handle_fatal_memory_error
          use mod_constants,   only : LAM_PINF
          integer(I32P),    intent(in) :: dim_num,samples_num,  &
                                          cluster_num,iter_max, &
                                          seed
          logical(I32P),    intent(in) :: logging,verbose
          character(len=*), intent(in) :: fname
          logical(I32P),    intent(in) :: append
          ! Locals
          character(len=256) :: emsg
          integer(I32P)      :: aerr
          ! Executable statemetns
          constructor%m_dim_num     = dim_num
          constructor%m_samples_num = samples_num
          constructor%m_cluster_num = cluster_num
          constructor%m_iter_max    = iter_max
          constructor%m_seedd       = seed
          associate(sn=>constructor%m_samples_num,   &
                    dn=>constructor%m_dim_num,       &
                    cn=>constructor%m_cluster_num )
                allocate( constructor%m_cluster(sn),            &
                          constructor%m_cluster_center(dn,cn),  &
                          constructor%m_cluster_population(cn), &
                          constructor%m_cluster_energy(cn),     &
                          STAT=aerr,                            &
                          ERRMSG=emsg   )
         end associate
         if(aerr /= 0) then
             call handle_fatal_memory_error(logging,verbose,append,fname, &
                                            "logger:205 --> mod_kmeans/constructor: -- Memory Allocation Failure !!", &
                                            "mod_kmeans/constructor:205 -- Memory Allocation Failure !!", &
                                            emsg,__LINE__ )
         end if
         constructor%m_cluster            = 0
         constructor%m_cluster_center     = LAM_PINF
         constructor%m_cluster_population = 0
         constructor%m_cluster_energy     = LAM_PINF
    end function

    !==========================================
    !       Getter procedures
    !==========================================
!DIR$ IF(USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_dim_num
!DIR$ ENDIF
    pure function get_dim_num(this) result(dim_num)
          class(Kmeans_t),  intent(in) :: this
          integer(I32P) :: dim_num
          dim_num = this%m_dim_num
    end function

!DIR$ IF(USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_samples_num
!DIR$ ENDIF
    pure function get_samples_num(this) result(samples_num)
          class(Kmeans_t),  intent(in) :: this
          integer(I32P) :: samples_num
          samples_num = this%m_samples_num
    end function

!DIR$ IF(USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_cluster_num
!DIR$ ENDIF
    pure function get_cluster_num(this) result(cluster_num)
          class(Kmeans_t), intent(in) :: this
          integer(I32P) :: cluster_num
          cluster_num = this%m_cluster_num
    end function

!DIR$ IF(USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_iter_max
!DIR$ ENDIF
    pure function get_iter_max(this) result(iter_max)
          class(Kmeans_t), intent(in) :: this
          integer(I32P) :: iter_max
          iter_max = this%m_iter_max
    end function

!DIR$ IF(USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_iter_num
!DIR$ ENDIF
    pure function get_iter_num(this) result(iter_num)
          class(Kmeans_t), intent(in) :: this
          integer(I32P) :: iter_num
          iter_num = this%m_iter_num
    end function

!DIR$ IF(USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_seed
!DIR$ ENDIF
    pure function get_seed(this) result(seed)
          class(Kmeans_t), intent(in) :: this
          integer(I32P) :: seed
          seed = this%m_seed
    end function

    !============================================
    !   Read/write procedures
    !============================================

     subroutine read_state(this,form,unit,ioerr)
          !implicit none
          class(Kmeans_t),         intent(in)    :: this
          character(len=*),        intent(in)    :: form
          integer(I32P),           intent(in)    :: unit
          integer(I32P),           intent(inout) :: ioerr
          ! Start of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              READ(unit,*,iostat=ioerr) this
          case default
              READ(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine read_state

    subroutine write_state(this,form,unit,ioerr)
         ! implicit none
          class(Kmeans_t),         intent(in)    :: this
          character(len=*),        intent(in)    :: form
          integer(I32P),           intent(in)    :: unit
          integer(I32P),           intent(inout) :: ioerr
          ! Start of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              WRITE(unit,*,iostat=ioerr) this
          case default
              WRITE(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine

    subroutine dbg_info(this)
          class(Kmeans_t), intent(in) :: this
          ! Exec code
          print*, "====================================================="
          print*, "         Dump of Kmeans_t object state               "
          print*, "====================================================="
          print*, " Collected on: ",__DATE__,":",__TIME__
          print*, "====================================================="
          print*, " m_dim_num:            ", this%m_dim_num
          print*, " m_samples_num:        ", this%m_samples_num
          print*, " m_cluster_num:        ", this%m_cluster_num
          print*, " m_iter_max:           ", this%m_iter_max
          print*, " m_iter_num:           ", this%m_iter_num
          print*, " m_seed:               ", this%m_seed
          print*, " m_cluster:            ", this%m_cluster
          print*, " m_cluster_center:     ", this%m_cluster_center
          print*, " m_cluster_population: ", this%m_cluster_population
          print*, " m_cluster_energy:     ", this%m_cluster_energy
          print*, "======================================================="
    end subroutine

    !
    subroutine compute_hmeans01(this,sig_samples,cluster_variance,fp_flags, &
                                samples_num,dim_num,cluster_num,verbose         )
          use kmeans_lib, only : cluster_initialize_5,     &
                                 hmeans_01,                &
                                 cluster_variance_compute, &
                                 cluster_print_summary
          use ISO_FORTRAN_ENV, only : ERROR_UNIT
          use ifcore
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          use, intrinsic :: ieee_exceptions
!DIR$ ENDIF
          class(Kmeans_t),  intent(inout) :: this
          real(R64P), dimension(dim_num,samples_num), intent(inout) :: sig_samples
          !DIR$ ASSUME_ALIGNED sig_samples:64
          real(R64P), dimension(cluster_num),         intent(inout) :: cluster_variance
          !DIR$ ASSUME_ALIGNED cluster_variance:64
          logical(I32P), dimension(5),                intent(inout) :: fp_flags
          integer(I32P),                              intent(in)    :: samples_num, &
                                                                       dim_num,     &
                                                                       cluster_num
          logical(I32P),                              intent(in)    :: verbose
          ! Locals
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type)                  :: status_value

!DIR$ ENDIF
          ! Exec code
          if(ANY(fp_flags) == .true.) then
              fp_flags = .false.
          end if
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_status(status_value)
          call ieee_set_halting_mode(ieee_all,.false.)
          call ieee_set_flag(ieee_all,.false.)
!DIR$ ENDIF
          call cluster_initialize_5(this%m_dim_num,this%m_samples_num, &
                                    this%m_cluster_num,sig_samples,    &
                                    this%m_seed,this%m_cluster_center  )

          call hmeans_01(this%m_dim_num,this%m_samples_num,this%m_cluster_num, &
                         this%m_iter_max,this%m_iter_num,sig_samples,          &
                         this%m_cluster,this%m_cluster_center,                 &
                         this%m_cluster_population,this%m_cluster_energy  )

          call cluster_variance_compute(this%m_dim_num,this%m_samples_num,     &
                                        this%m_cluster_num,sig_samples,        &
                                        this%m_cluster,this%m_cluster_center,  &
                                        cluster_variance                    )
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_flag(ieee_all,fp_flags)
          if(ANY(fp_flags)) then
                write(ERROR_UNIT,*) "====================================================================="
                write(ERROR_UNIT,*) " Kmeans_t%compute_hmeans01: FLOATING-POINT EXECEPTION(S) OCCURRED"
                write(ERROR_UNIT,*) "====================================================================="
          end if
          call ieee_set_status(status_value)
!DIR$ ENDIF
          if(verbose == .true.) then
              call cluster_print_summary(this%m_samples_num,this%m_cluster_num,  &
                                this%m_cluster_population,this%m_cluster_energy, &
                                cluster_variance                                )
          end if
    end subroutine

    subroutine compute_hmeans02(this,sig_samples,cluster_variance,fp_flags,    &
                                samples_num,dim_num,cluster_num,verbose     )
          use kmeans_lib, only : cluster_initialize_5,      &
                                 hmeans_02,                 &
                                 cluster_variance_compute,  &
                                 cluster_print_summary
          use ISO_FORTRAN_ENV, only : ERROR_UNIT
          use ifcore,
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          use, intrinsic :: ieee_exceptions
!DIR$ ENDIF
          class(Kmeans_t),  intent(inout) :: this
          real(R64P), dimension(dim_num,samples_num), intent(inout) :: sig_samples
          !DIR$ ASSUME_ALIGNED sig_samples:64
          real(R64P), dimension(cluster_num),         intent(out)   :: cluster_variance
          !DIR$ ASSUME_ALIGNED cluster_variance:64
          logical(I32P), dimension(5),                intent(inout) :: fp_flags
          integer(I32P),                              intent(in)    :: samples_num, &
                                                                       dim_num,     &
                                                                       cluster_num
          logical(I32P),                              intent(in)    :: verbose
          ! Locals
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type)                  :: status_value

!DIR$ ENDIF
          ! Exec code
          if(ANY(fp_flags) == .true.) then
              fp_flags = .false.
          end if
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_status(status_value)
          call ieee_set_halting_mode(ieee_all,.false.)
          call ieee_set_flag(ieee_all,.false.)
!DIR$ ENDIF
          call cluster_initialize_5(this%m_dim_num,this%m_samples_num,this%m_cluster_num, &
                                    sig_samples,this%m_seed,this%m_cluster_center   )

          call hmeans_02(this%m_dim_num,this%m_samples_num,this%m_cluster_num,this%m_iter_max, &
                         this%m_iter_num,sig_samples,this%m_cluster,this%m_cluster_center,     &
                         this%m_cluster_population,this%m_cluster_energy,this%m_seed        )

          call cluster_variance_compute(this%m_dim_num,this%m_samples_num,this%m_cluster_num, &
                                        sig_samples,this%m_cluster_center,cluster_variance  )

!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_flag(ieee_all,fp_flags)
          if(ANY(fp_flags)) then
                write(ERROR_UNIT,*) "====================================================================="
                write(ERROR_UNIT,*) " Kmeans_t%compute_hmeans02: FLOATING-POINT EXECEPTION(S) OCCURRED"
                write(ERROR_UNIT,*) "====================================================================="
          end if
          call ieee_set_status(status_value)
!DIR$ ENDIF
          if(verbose == .true.) then
              call cluster_print_summary(this%m_samples_num,this%m_cluster_num,   &
                               this%m_cluster_population,this%m_cluster_energy,   &
                               cluster_variance                     )
         end if

    end subroutine

    subroutine compute_kmeans01(this,sig_samples,cluster_variance,fp_flags, &
                                samples_num,dim_num,cluster_num,verbose  )
          use kmeans_lib, only : cluster_initialize_5, &
                                 kmeans_01,            &
                                 cluster_variance_compute, &
                                 cluster_print_summary
          use ISO_FORTRAN_ENV, only : ERROR_UNIT
          use ifcore,
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          use, intrinsic :: ieee_exceptions
!DIR$ ENDIF
          class(Kmeans_t),      intent(inout) :: this
          real(R64P), dimension(dim_num,samples_num), intent(inout) :: sig_samples
          !DIR$ ASSUME_ALIGNED sig_samples:64
          real(R64P), dimension(cluster_num),         intent(out)   :: cluster_variance
          !DIR$ ASSUME_ALIGNED cluster_variance:64
          logical(I32P), dimension(5),                intent(inout) :: fp_flags
          integer(I32P),                              intent(in)    :: samples_num, &
                                                                       dim_num,     &
                                                                       cluster_num
          logical(I32P),                              intent(in)    :: verbose
          ! Locals
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type)                  :: status_value

!DIR$ ENDIF
          ! Exec code
          if(ANY(fp_flags) == .true) then
              fp_flags = .false.
          end if
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_status(status_value)
          call ieee_set_halting_mode(ieee_all,.false.)
          call ieee_set_flag(ieee_all,.false.)
!DIR$ ENDIF
          call cluster_initialize_5(this%m_dim_num,this%m_samples_num,this%m_cluster_num, &
                                    sig_samples,this%m_seed,this%m_cluster_center   )

          call kmeans_01(this%m_dim_num,this%m_samples_num,this%m_cluster_num,  &
                         this%m_iter_max,this%m_iter_num,sig_samples,           &
                         this%m_cluster,this%m_cluster_center,                  &
                         this%m_cluster_population,this%m_cluster_energy   )

          call cluster_variance_compute(this%m_dim_num,this%m_samples_num,this%m_cluster_num, &
                                        sig_samples,this%m_cluster,this%m_cluster_center,     &
                                        cluster_variance                                )

!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_flag(ieee_all,fp_flags)
          if(ANY(fp_flags)) then
                write(ERROR_UNIT,*) "====================================================================="
                write(ERROR_UNIT,*) " Kmeans_t%compute_kmeans01: FLOATING-POINT EXECEPTION(S) OCCURRED"
                write(ERROR_UNIT,*) "====================================================================="
          end if
          call ieee_set_status(status_value)
!DIR$ ENDIF
          if(verbose == .true.) then
              call cluster_print_summary(this%m_samples_num,this%m_cluster_num,   &
                                    this%m_cluster_population,this%m_cluster_energy, &
                                    cluster_variance                                )
          end if

    end subroutine

    subroutine compute_kmeans02(this,sig_samples,cluster_variance,fp_flags,  &
                                samples_num,dim_num,cluster_num,verbose   )
          use kmeans_lib, only : cluster_initialize_1, &
                                 kmeans_02,            &
                                 cluster_variance_compute, &
                                 cluster_print_summary
          use ISO_FORTRAN_ENV, only : ERROR_UNIT
          use ifcore,
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          use, intrinsic :: ieee_exceptions
!DIR$ ENDIF
          class(Kmeans_t),                            intent(inout) :: this
          real(R64P), dimension(dim_num,samples_num), intent(inout) :: sig_samples
          !DIR$ ASSUME_ALIGNED sig_samples:64
          real(R64P), dimension(cluster_num),         intent(out)   :: cluster_variance
          !DIR$ ASSUME_ALIGNED cluster_variance:64
          integer(I32P),                              intent(in)    :: samples_num, &
                                                                       dim_num,     &
                                                                       cluster_num
          logical(I32P),                              intent(in)    :: verbose
          ! Locals
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type)                  :: status_value

!DIR$ ENDIF
          ! Exec code
          if(ANY(fp_flags) == .true.) then
              fp_flags = .false.
          end if
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_status(status_value)
          call ieee_set_halting_mode(ieee_all,.false.)
          call ieee_set_flag(ieee_all,.false.)
!DIR$ ENDIF
          call cluster_initialize_1(this%m_dim_num,this%m_samples_num,this%m_cluster_num, &
                                    sig_samples,this%m_cluster_center           )

          call kmeans_02(this%m_dim_num,this%m_samples_num,this%m_cluster_num,  &
                         this%m_iter_max,this%m_iter_max,sig_samples,this%m_cluster, &
                         this%m_cluster_center,this%m_cluster_population,this%m_cluster_energy )

          call cluster_variance_compute(this%m_dim_num,this%m_samples_num,this%m_cluster_num, &
                                        sig_samples,this%m_cluster,this%m_cluster_center,cluster_variance     )
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_flag(ieee_all,fp_flags)
          if(ANY(fp_flags)) then
                write(ERROR_UNIT,*) "====================================================================="
                write(ERROR_UNIT,*) " Kmeans_t%compute_kmeans02: FLOATING-POINT EXECEPTION(S) OCCURRED"
                write(ERROR_UNIT,*) "====================================================================="
          end if
          call ieee_set_status(status_value)
!DIR$ ENDIF
          if(verbose == .true.) then
              call cluster_print_summary(this%m_samples_num,this%m_cluster_num,   &
                                this%m_cluster_population,this%m_cluster_energy,  &
                                cluster_variance                            )
          end if

    end subroutine

    subroutine compute_kmeans03(this,sig_samples,cluster_variance,fp_flags,  &
                                samples_num,dim_num,cluster_num,verbose  )
          use kmeans_lib, only : cluster_initialize_1, &
                                 kmeans_03,            &
                                 cluster_variance_compute, &
                                 cluster_print_summary
          use ISO_FORTRAN_ENV, only : ERROR_UNIT
          use ifcore,
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          use, intrinsic :: ieee_exceptions
!DIR$ ENDIF
          class(Kmeans_t),      intent(inout) :: this
          real(R64P), dimension(dim_num,samples_num), intent(inout) :: sig_samples
          !DIR$ ASSUME_ALIGNED sig_samples:64
          real(R64P), dimension(cluster_num),         intent(out)   :: cluster_variance
          !DIR$ ASSUME_ALIGNED cluster_variance:64
          logical(I32P), dimension(5),                intent(inout) :: fp_flags
          integer(I32P),                              intent(in)    :: samples_num, &
                                                                       dim_num,     &
                                                                       cluster_num
          logical(I32P),                              intent(in)    :: verbose
          ! Locals
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type)                  :: status_value

!DIR$ ENDIF
          ! Exec code
          if(ANY(fp_flags) == .true.) then
              fp_flags = .false.
          end if
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_status(status_value)
          call ieee_set_halting_mode(ieee_all,.false.)
          call ieee_set_flag(ieee_all,.false.)
!DIR$ ENDIF
          call cluster_initialize_1(this%m_dim_num,         &
                                    this%m_samples_num,     &
                                    this%m_cluster_num,     &
                                    sig_samples,            &
                                    this%m_cluster_center   )

          call kmeans_03(this%m_dim_num,        &
                         this%m_samples_num,    &
                         this%m_cluster_num,    &
                         this%m_iter_max,       &
                         this%m_iter_num,       &
                         sig_samples,           &
                         this%m_cluster,        &
                         this%m_cluster_center, &
                         this%m_cluster_population, &
                         this%m_cluster_energy    )

          call cluster_variance_compute(this%m_dim_num,     &
                                        this%m_samples_num, &
                                        this%m_cluster_num, &
                                        sig_samples,        &
                                        this%m_cluster,     &
                                        cluster_variance  )
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_flag(ieee_all,fp_flags)
          if(ANY(fp_flags)) then
                write(ERROR_UNIT,*) "====================================================================="
                write(ERROR_UNIT,*) " Kmeans_t%compute_kmeans03: FLOATING-POINT EXECEPTION(S) OCCURRED"
                write(ERROR_UNIT,*) "====================================================================="
          end if
          call ieee_set_status(status_value)

!DIR$ ENDIF
             if(verbose == .true.) then
              call cluster_print_summary(this%m_samples_num,  &
                                         this%m_cluster_num,  &
                                         this%m_cluster_population, &
                                         this%m_cluster_energy,     &
                                         cluster_variance           )
             end if

    end subroutine

    subroutine compute_hmeans01_kmeans01(this,sig_samples,cluster_variance,fp_flags,  &
                                         samples_num,dim_num,cluster_num,verbose   )
          use kmeans_lib, only : cluster_initialize_5,     &
                                 hmeans_01,                &
                                 cluster_variance_compute, &
                                 cluster_print_summary,    &
                                 kmeans_01
          use ISO_FORTRAN_ENV, only : ERROR_UNIT
          use ifcore,
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          use, intrinsic :: ieee_exceptions
!DIR$ ENDIF
          class(Kmeans_t),                              intent(inout) :: this
          real(R64P), dimension(dim_num,samples_num),   intent(inout) :: sig_samples
          !DIR$ ASSUME_ALIGNED sig_samples:64
          real(R64P), dimension(cluster_num),           intent(out)   :: cluster_variance
          !DIR$ ASSUME_ALIGNED cluster_variance:64
          logical(I32P), dimension(5),                  intent(inout) :: fp_flags
          integer(I32P),                                intent(in)    :: samples_num,dim_num, &
                                                                         cluster_num
          logical(I32P),                                intent(in)    :: verbose
          ! Locals
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type)                  :: status_value

!DIR$ ENDIF
          ! Exec code
          if(ANY(fp_flags) == .true.) then
              fp_flags = .false.
          end if
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_status(status_value)
          call ieee_set_halting_mode(ieee_all,.false.)
          call ieee_set_flag(ieee_all,.false.)
!DIR$ ENDIF
          call cluster_initialize_5(this%m_dim_num,         &
                                    this%m_samples_num,     &
                                    this%m_cluster_num,     &
                                    sig_samples,            &
                                    this%m_seed,            &
                                    this%m_cluster_center   )

          call hmeans_01( this%m_dim_num,         &
                          this%m_samples_num,     &
                          this%m_cluster_num,     &
                          this%m_iter_max,        &
                          this%m_iter_num,        &
                          sig_samples,            &
                          this%m_cluster,         &
                          this%m_cluster_center,  &
                          this%m_cluster_population, &
                          this%m_cluster_energy    )

          call cluster_variance_compute( this%m_dim_num,         &
                                         this%m_samples_num,     &
                                         this%m_cluster_num,     &
                                         sig_samples,            &
                                         this%m_cluster,         &
                                         this%m_cluster_center,  &
                                         cluster_variance        )

           call kmeans_01(this%m_dim_num,         &
                          this%m_samples_num,     &
                          this%m_cluster_num,     &
                          this%m_iter_max,        &
                          this%m_iter_num,        &
                          sig_samples,            &
                          this%m_cluster,         &
                          this%m_cluster_center,  &
                          this%m_cluster_population, &
                          this%m_cluster_energy    )

           call cluster_variance_compute(this%m_dim_num,         &
                                         this%m_samples_num,     &
                                         this%m_cluster_num,     &
                                         sig_samples,            &
                                         this%m_cluster,         &
                                         this%m_cluster_center,  &
                                         cluster_variance        )
 !DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_flag(ieee_all,fp_flags)
          if(ANY(fp_flags)) then
                write(ERROR_UNIT,*) "====================================================================="
                write(ERROR_UNIT,*) " Kmeans_t%compute_hmeans01_kmeans01: FLOATING-POINT EXECEPTION(S) OCCURRED"
                write(ERROR_UNIT,*) "====================================================================="
          end if
          call ieee_set_status(status_value)

!DIR$ ENDIF
          if(verbose == .true.) then
              call cluster_print_summary( this%m_samples_num,  &
                                         this%m_cluster_num,  &
                                         this%m_cluster_population, &
                                         this%m_cluster_energy,     &
                                         cluster_variance           )
          end if

    end subroutine

    subroutine  compute_hmeans01_kmeans02(this,sig_samples,cluster_variance,fp_flags, &
                                          samples_num,dim_num,cluster_num,verbose   )
          use kmeans_lib, only : cluster_initialize_5,  &
                                 hmeans_01,             &
                                 cluster_variance_compute, &
                                 kmeans_02 , &
                                 cluster_print_summary
          use ISO_FORTRAN_ENV, only : ERROR_UNIT
          use ifcore,
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          use, intrinsic :: ieee_exceptions
!DIR$ ENDIF
          class(Kmeans_t),                              intent(inout) :: this
          real(R64P), dimension(dim_num,samples_num),   intent(inout) :: sig_samples
          !DIR$ ASSUME_ALIGNED sig_samples:64
          real(R64P), dimension(cluster_num),           intent(out)   :: cluster_variance
          !DIR$ ASSUME_ALIGNED cluster_variance:64
          logical(I32P), dimension(5),                  intent(inout) :: fp_flags
          integer(I32P),                                intent(in)    :: samples_num,dim_num, &
                                                                         cluster_num
          logical(I32P),                                intent(in)    :: verbose
          ! Locals
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type)                  :: status_value

!DIR$ ENDIF
          ! Exec code
          if(ANY(fp_flags) == .true.) then
              fp_flags = .false.
          end if
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_status(status_value)
          call ieee_set_halting_mode(ieee_all,.false.)
          call ieee_set_flag(ieee_all,.false.)
!DIR$ ENDIF
          call cluster_initialize_5(this%m_dim_num,         &
                                    this%m_samples_num,     &
                                    this%m_cluster_num,     &
                                    sig_samples,            &
                                    this%m_seed,            &
                                    this%m_cluster_center   )

          call hmeans_01( this%m_dim_num,         &
                          this%m_samples_num,     &
                          this%m_cluster_num,     &
                          this%m_iter_max,        &
                          this%m_iter_num,        &
                          sig_samples,            &
                          this%m_cluster,         &
                          this%m_cluster_center,  &
                          this%m_cluster_population, &
                          this%m_cluster_energy    )

          call cluster_variance_compute( this%m_dim_num,         &
                                         this%m_samples_num,     &
                                         this%m_cluster_num,     &
                                         sig_samples,            &
                                         this%m_cluster,         &
                                         this%m_cluster_center,  &
                                         cluster_variance        )

           call kmeans_02(this%m_dim_num,         &
                          this%m_samples_num,     &
                          this%m_cluster_num,     &
                          this%m_iter_max,        &
                          this%m_iter_num,        &
                          sig_samples,            &
                          this%m_cluster,         &
                          this%m_cluster_center,  &
                          this%m_cluster_population, &
                          this%m_cluster_energy    )

           call cluster_variance_compute(this%m_dim_num,         &
                                         this%m_samples_num,     &
                                         this%m_cluster_num,     &
                                         sig_samples,            &
                                         this%m_cluster,         &
                                         this%m_cluster_center,  &
                                         cluster_variance        )
 !DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_flag(ieee_all,fp_flags)
          if(ANY(fp_flags)) then
                write(ERROR_UNIT,*) "====================================================================="
                write(ERROR_UNIT,*) " Kmeans_t%compute_hmeans01_kmeans02: FLOATING-POINT EXECEPTION(S) OCCURRED"
                write(ERROR_UNIT,*) "====================================================================="
          end if
          call ieee_set_status(status_value)

!DIR$ ENDIF
          if(verbose == .true.) then
              call cluster_print_summary( this%m_samples_num,  &
                                         this%m_cluster_num,  &
                                         this%m_cluster_population, &
                                         this%m_cluster_energy,     &
                                         cluster_variance           )
          end if
    end subroutine

    subroutine compute_hmeans01_kmeans03(this,sig_samples,cluster_variance,fp_flags, &
                                          samples_num,dim_num,cluster_num,verbose   )
          use kmeans_lib, only : cluster_initialize_5,  &
                                 hmeans_01,             &
                                 cluster_variance_compute, &
                                 kmeans_03,                &
                                 cluster_print_summary
          use ISO_FORTRAN_ENV, only : ERROR_UNIT
          use ifcore,
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          use, intrinsic :: ieee_exceptions
!DIR$ ENDIF
          class(Kmeans_t),                              intent(inout) :: this
          real(R64P), dimension(dim_num,samples_num),   intent(inout) :: sig_samples
          !DIR$ ASSUME_ALIGNED sig_samples:64
          real(R64P), dimension(cluster_num),           intent(out)   :: cluster_variance
          !DIR$ ASSUME_ALIGNED cluster_variance:64
          logical(I32P), dimension(5),                  intent(inout) :: fp_flags
          integer(I32P),                                intent(in)    :: samples_num,dim_num, &
                                                                         cluster_num
          logical(I32P),                                intent(in)    :: verbose
          ! Locals
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          type(ieee_status_type)                  :: status_value

!DIR$ ENDIF
          ! Exec code
          if(ANY(fp_flags) == .true.) then
              fp_flags = .false.
          end if
!DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_status(status_value)
          call ieee_set_halting_mode(ieee_all,.false.)
          call ieee_set_flag(ieee_all,.false.)
!DIR$ ENDIF
          call cluster_initialize_5(this%m_dim_num,         &
                                    this%m_samples_num,     &
                                    this%m_cluster_num,     &
                                    sig_samples,            &
                                    this%m_seed,            &
                                    this%m_cluster_center   )

          call hmeans_01( this%m_dim_num,         &
                          this%m_samples_num,     &
                          this%m_cluster_num,     &
                          this%m_iter_max,        &
                          this%m_iter_num,        &
                          sig_samples,            &
                          this%m_cluster,         &
                          this%m_cluster_center,  &
                          this%m_cluster_population, &
                          this%m_cluster_energy    )

          call cluster_variance_compute( this%m_dim_num,         &
                                         this%m_samples_num,     &
                                         this%m_cluster_num,     &
                                         sig_samples,            &
                                         this%m_cluster,         &
                                         this%m_cluster_center,  &
                                         cluster_variance        )

           call kmeans_03(this%m_dim_num,         &
                          this%m_samples_num,     &
                          this%m_cluster_num,     &
                          this%m_iter_max,        &
                          this%m_iter_num,        &
                          sig_samples,            &
                          this%m_cluster,         &
                          this%m_cluster_center,  &
                          this%m_cluster_population, &
                          this%m_cluster_energy    )

           call cluster_variance_compute(this%m_dim_num,         &
                                         this%m_samples_num,     &
                                         this%m_cluster_num,     &
                                         sig_samples,            &
                                         this%m_cluster,         &
                                         this%m_cluster_center,  &
                                         cluster_variance        )
 !DIR$ IF (USE_IEEE_EXCEPTION_HANDLING .EQ. 1)
          call ieee_get_flag(ieee_all,fp_flags)
          if(ANY(fp_flags)) then
                write(ERROR_UNIT,*) "====================================================================="
                write(ERROR_UNIT,*) " Kmeans_t%compute_hmeans01_kmeans03: FLOATING-POINT EXECEPTION(S) OCCURRED"
                write(ERROR_UNIT,*) "====================================================================="
          end if
          call ieee_set_status(status_value)

!DIR$ ENDIF
          if(verbose == .true.) then
              call cluster_print_summary( this%m_samples_num,  &
                                         this%m_cluster_num,  &
                                         this%m_cluster_population, &
                                         this%m_cluster_energy,     &
                                         cluster_variance           )
          end if
       end subroutine

end module mod_kmeans


module mod_fold_functions

implicit none

public

contains

pure integer(kind=int8) function sum_i1(x,y) result(res)
  use iso_fortran_env,only:int8
  integer(kind=int8),intent(in) :: x,y
  res = x + y
endfunction sum_i1

pure integer(kind=int16) function sum_i2(x,y) result(res)
  use iso_fortran_env,only:int16
  integer(kind=int16),intent(in) :: x,y
  res = x + y
endfunction sum_i2

pure integer(kind=int32) function sum_i4(x,y) result(res)
  use iso_fortran_env,only:int32
  integer(kind=int32),intent(in) :: x,y
  res = x + y
endfunction sum_i4

pure integer(kind=int64) function sum_i8(x,y) result(res)
  use iso_fortran_env,only:int64
  integer(kind=int64),intent(in) :: x,y
  res = x + y
endfunction sum_i8

pure real(kind=real32) function sum_r4(x,y) result(res)
  use iso_fortran_env,only:real32
  real(kind=real32),intent(in) :: x,y
  res = x + y
endfunction sum_r4

pure real(kind=real64) function sum_r8(x,y) result(res)
  use iso_fortran_env,only:real64
  real(kind=real64),intent(in) :: x,y
  res = x + y
endfunction sum_r8

pure real(kind=real128) function sum_r16(x,y) result(res)
  use iso_fortran_env,only:real128
  real(kind=real128),intent(in) :: x,y
  res = x + y
endfunction sum_r16

pure complex(kind=real32) function sum_c4(x,y) result(res)
  use iso_fortran_env,only:real32
  complex(kind=real32),intent(in) :: x,y
  res = x + y
endfunction sum_c4

pure complex(kind=real64) function sum_c8(x,y) result(res)
  use iso_fortran_env,only:real64
  complex(kind=real64),intent(in) :: x,y
  res = x + y
endfunction sum_c8

pure complex(kind=real128) function sum_c16(x,y) result(res)
  use iso_fortran_env,only:real128
  complex(kind=real128),intent(in) :: x,y
  res = x + y
endfunction sum_c16

endmodule mod_fold_functions

program test_foldt
use iso_fortran_env,only:int8,int16,int32,int64,real32,real64,real128
use mod_testing,only:assert,initialize_tests,report_tests
use mod_functional
use mod_fold_functions

implicit none

logical,dimension(:),allocatable :: tests
logical :: test_failed
integer :: n,norder,ntests
integer,parameter :: stdout = 6

complex(kind=real32),dimension(:),allocatable :: c4
complex(kind=real64),dimension(:),allocatable :: c8
complex(kind=real128),dimension(:),allocatable :: c16
complex(kind=real64) :: c8_start
complex(kind=real128) :: c16_start

n = 1
ntests = 10
call initialize_tests(tests,ntests)

tests(n) = assert(foldt(sum_i1,0_int8,[1_int8,2_int8,3_int8,4_int8,5_int8]) == 15,&
                        'foldt, int8')
n = n + 1

tests(n) = assert(foldt(sum_i2,0_int16,[1_int16,2_int16,3_int16,4_int16,5_int16]) == 15,&
                        'foldt, int16')
n = n + 1

tests(n) = assert(foldt(sum_i4,0_int32,[1_int32,2_int32,3_int32,4_int32,5_int32]) == 15,&
                        'foldt, int32')
n = n + 1

tests(n) = assert(foldt(sum_i8,0_int64,[1_int64,2_int64,3_int64,4_int64,5_int64]) == 15,&
                        'foldt, int64')
n = n + 1

tests(n) = assert(foldt(sum_r4,0._real32,[1._real32,2._real32,3._real32,4._real32,5._real32]) == 15,&
                        'foldt, real32')
n = n + 1

tests(n) = assert(foldt(sum_r8,0._real64,[1._real64,2._real64,3._real64,4._real64,5._real64]) == 15,&
                        'foldt, real64')
n = n + 1

tests(n) = assert(foldt(sum_r16,0._real128,[1._real128,2._real128,3._real128,4._real128,5._real128]) == 15,&
                        'foldt, real128')
n = n + 1

c4 = arange(cmplx(1,0),cmplx(5,0))
c8 = c4
c16 = c4

c8_start = cmplx(0,0)
c16_start = c8_start

tests(n) = assert(foldt(sum_c4,cmplx(0.,0.),c4) == cmplx(15,0),&
                  'foldt, complex real32')
n = n + 1

tests(n) = assert(foldt(sum_c8,c8_start,c8) == cmplx(15._real64,0._real64),&
                  'foldt, complex real64')
n = n + 1

tests(n) = assert(foldt(sum_c16,c16_start,c16) == cmplx(15._real128,0._real128),&
                  'foldt, complex real128')
n = n + 1

test_failed = .false.
call report_tests(tests,test_failed)
if(test_failed)stop 1

endprogram test_foldt