      SUBROUTINE MB04WU( TRANQ1, TRANQ2, M, N, K, Q1, LDQ1, Q2, LDQ2,
     $                   CS, TAU, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To generate a matrix Q with orthogonal columns (spanning an
C     isotropic subspace), which is defined as the first n columns
C     of a product of symplectic reflectors and Givens rotations,
C
C         Q = diag( H(1),H(1) ) G(1) diag( F(1),F(1) )
C             diag( H(2),H(2) ) G(2) diag( F(2),F(2) )
C                               ....
C             diag( H(k),H(k) ) G(k) diag( F(k),F(k) ).
C
C     The matrix Q is returned in terms of its first 2*M rows
C
C                      [  op( Q1 )   op( Q2 ) ]
C                  Q = [                      ].
C                      [ -op( Q2 )   op( Q1 ) ]
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TRANQ1  CHARACTER*1
C             Specifies the form of op( Q1 ) as follows:
C             = 'N':  op( Q1 ) = Q1;
C             = 'T':  op( Q1 ) = Q1';
C             = 'C':  op( Q1 ) = Q1'.
C
C     TRANQ2  CHARACTER*1
C             Specifies the form of op( Q2 ) as follows:
C             = 'N':  op( Q2 ) = Q2;
C             = 'T':  op( Q2 ) = Q2';
C             = 'C':  op( Q2 ) = Q2'.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrices Q1 and Q2. M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrices Q1 and Q2.
C             M >= N >= 0.
C
C     K       (input) INTEGER
C             The number of symplectic Givens rotations whose product
C             partly defines the matrix Q. N >= K >= 0.
C
C     Q1      (input/output) DOUBLE PRECISION array, dimension
C                     (LDQ1,N) if TRANQ1 = 'N',
C                     (LDQ1,M) if TRANQ1 = 'T' or TRANQ1 = 'C'
C             On entry with TRANQ1 = 'N', the leading M-by-K part of
C             this array must contain in its i-th column the vector
C             which defines the elementary reflector F(i).
C             On entry with TRANQ1 = 'T' or TRANQ1 = 'C', the leading
C             K-by-M part of this array must contain in its i-th row
C             the vector which defines the elementary reflector F(i).
C             On exit with TRANQ1 = 'N', the leading M-by-N part of this
C             array contains the matrix Q1.
C             On exit with TRANQ1 = 'T' or TRANQ1 = 'C', the leading
C             N-by-M part of this array contains the matrix Q1'.
C
C     LDQ1    INTEGER
C             The leading dimension of the array Q1.
C             LDQ1 >= MAX(1,M),  if TRANQ1 = 'N';
C             LDQ1 >= MAX(1,N),  if TRANQ1 = 'T' or TRANQ1 = 'C'.
C
C     Q2      (input/output) DOUBLE PRECISION array, dimension
C                     (LDQ2,N) if TRANQ2 = 'N',
C                     (LDQ2,M) if TRANQ2 = 'T' or TRANQ2 = 'C'
C             On entry with TRANQ2 = 'N', the leading M-by-K part of
C             this array must contain in its i-th column the vector
C             which defines the elementary reflector H(i) and, on the
C             diagonal, the scalar factor of H(i).
C             On entry with TRANQ2 = 'T' or TRANQ2 = 'C', the leading
C             K-by-M part of this array must contain in its i-th row the
C             vector which defines the elementary reflector H(i) and, on
C             the diagonal, the scalar factor of H(i).
C             On exit with TRANQ2 = 'N', the leading M-by-N part of this
C             array contains the matrix Q2.
C             On exit with TRANQ2 = 'T' or TRANQ2 = 'C', the leading
C             N-by-M part of this array contains the matrix Q2'.
C
C     LDQ2    INTEGER
C             The leading dimension of the array Q2.
C             LDQ2 >= MAX(1,M),  if TRANQ2 = 'N';
C             LDQ2 >= MAX(1,N),  if TRANQ2 = 'T' or TRANQ2 = 'C'.
C
C     CS      (input) DOUBLE PRECISION array, dimension (2*K)
C             On entry, the first 2*K elements of this array must
C             contain the cosines and sines of the symplectic Givens
C             rotations G(i).
C
C     TAU     (input) DOUBLE PRECISION array, dimension (K)
C             On entry, the first K elements of this array must
C             contain the scalar factors of the elementary reflectors
C             F(i).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -13,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX(1,M+N).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     REFERENCES
C
C     [1] Bunse-Gerstner, A.
C         Matrix factorizations for symplectic QR-like methods.
C         Linear Algebra Appl., 83, pp. 49-77, 1986.
C
C     CONTRIBUTORS
C
C     D. Kressner, Technical Univ. Berlin, Germany, and
C     P. Benner, Technical Univ. Chemnitz, Germany, December 2003.
C
C     REVISIONS
C
C     V. Sima, June 2008 (SLICOT version of the HAPACK routine DOSGSQ).
C
C     KEYWORDS
C
C     Elementary matrix operations, orthogonal symplectic matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     .. Scalar Arguments ..
      CHARACTER         TRANQ1, TRANQ2
      INTEGER           INFO, K, LDQ1, LDQ2, LDWORK, M, N
C     .. Array Arguments ..
      DOUBLE PRECISION  CS(*), DWORK(*), Q1(LDQ1,*), Q2(LDQ2,*), TAU(*)
C     .. Local Scalars ..
      LOGICAL           LTRQ1, LTRQ2
      INTEGER           I, J
      DOUBLE PRECISION  NU
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DLARF, DLASET, DROT, DSCAL, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO  = 0
      LTRQ1 = LSAME( TRANQ1,'T' ) .OR. LSAME( TRANQ1,'C' )
      LTRQ2 = LSAME( TRANQ2,'T' ) .OR. LSAME( TRANQ2,'C' )
C
C     Check the scalar input parameters.
C
      IF ( .NOT.( LTRQ1 .OR. LSAME( TRANQ1, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF ( .NOT.( LTRQ2 .OR. LSAME( TRANQ2, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF ( M.LT.0 ) THEN
         INFO = -3
      ELSE IF ( N.LT.0 .OR. N.GT.M ) THEN
         INFO = -4
      ELSE IF ( K.LT.0 .OR. K.GT.N ) THEN
         INFO = -5
      ELSE IF ( ( LTRQ1 .AND. LDQ1.LT.MAX( 1, N ) ) .OR.
     $     ( .NOT.LTRQ1 .AND. LDQ1.LT.MAX( 1, M ) ) ) THEN
         INFO = -7
      ELSE IF ( ( LTRQ2 .AND. LDQ2.LT.MAX( 1, N ) ) .OR.
     $     ( .NOT.LTRQ2 .AND. LDQ2.LT.MAX( 1, M ) ) ) THEN
         INFO = -9
      ELSE IF ( LDWORK.LT.MAX( 1,M + N ) ) THEN
         DWORK(1) = DBLE( MAX( 1,M + N ) )
         INFO = -13
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04WU', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Initialize columns K+1:N to columns of the unit matrix.
C
      DO 20 J = K + 1, N
         DO 10 I = 1, M
            Q1(I,J) = ZERO
   10    CONTINUE
         Q1(J,J) = ONE
   20 CONTINUE
      CALL DLASET( 'All', M, N-K, ZERO, ZERO, Q2(1,K+1), LDQ2 )
C
      IF ( LTRQ1.AND.LTRQ2 ) THEN
         DO 50 I = K, 1, -1
C
C           Apply F(I) to Q1(I+1:N,I:M) and Q2(I+1:N,I:M) from the
C           right.
C
            CALL DCOPY( M-I+1, Q2(I,I), LDQ2, DWORK, 1 )
            IF ( I.LT.N ) THEN
               Q1(I,I) = ONE
               CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I),
     $                     Q1(I+1,I), LDQ1, DWORK(M+1) )
               CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I),
     $                     Q2(I+1,I), LDQ2, DWORK(M+1) )
            END IF
            IF ( I.LT.M )
     $         CALL DSCAL( M-I, -TAU(I), Q1(I,I+1), LDQ1 )
            Q1(I,I) = ONE - TAU(I)
C
C           Set Q1(I,1:I-1) and Q2(I,1:M) to zero.
C
            DO 30 J = 1, I - 1
               Q1(I,J) = ZERO
   30       CONTINUE
            DO 40 J = 1, M
               Q2(I,J) = ZERO
   40       CONTINUE
C
C           Apply G(I) to Q1(I:N,I) and Q2(I:N,I) from the right.
C
            CALL DROT( N-I+1, Q1(I,I), 1, Q2(I,I), 1, CS(2*I-1),
     $                 CS(2*I) )
C
C           Apply H(I) to Q1(I:N,I:M) and Q2(I:N,I:M) from the right.
C
            NU = DWORK(1)
            DWORK(1) = ONE
            CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q1(I,I),
     $                  LDQ1, DWORK(M+1) )
            CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q2(I,I),
     $                  LDQ2, DWORK(M+1) )
   50    CONTINUE
      ELSE IF ( LTRQ1 ) THEN
         DO 80 I = K, 1, -1
C
C           Apply F(I) to Q1(I+1:N,I:M) from the right and to
C           Q2(I:M,I+1:N) from the left.
C
            CALL DCOPY( M-I+1, Q2(I,I), 1, DWORK, 1 )
            IF ( I.LT.N ) THEN
               Q1(I,I) = ONE
               CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), LDQ1, TAU(I),
     $                     Q1(I+1,I), LDQ1, DWORK(M+1) )
               CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), LDQ1, TAU(I),
     $                     Q2(I,I+1), LDQ2, DWORK(M+1) )
            END IF
            IF ( I.LT.M )
     $         CALL DSCAL( M-I, -TAU(I), Q1(I,I+1), LDQ1 )
            Q1(I,I) = ONE - TAU(I)
C
C           Set Q1(I,1:I-1) and Q2(1:M,I) to zero.
C
            DO 60 J = 1, I - 1
               Q1(I,J) = ZERO
   60       CONTINUE
            DO 70 J = 1, M
               Q2(J,I) = ZERO
   70       CONTINUE
C
C           Apply G(I) to Q1(I:N,I) from the right and to Q2(I,I:N)
C           from the left.
C
            CALL DROT( N-I+1, Q1(I,I), 1, Q2(I,I), LDQ2, CS(2*I-1),
     $                 CS(2*I) )
C
C           Apply H(I) to Q1(I:N,I:M) from the right and to Q2(I:M,I:N)
C           from the left.
C
            NU = DWORK(1)
            DWORK(1) = ONE
            CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q1(I,I),
     $                  LDQ1, DWORK(M+1) )
            CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q2(I,I),
     $                  LDQ2, DWORK(M+1) )
   80    CONTINUE
      ELSE IF ( LTRQ2 ) THEN
         DO 110 I = K, 1, -1
C
C           Apply F(I) to Q1(I:M,I+1:N) from the left and to
C           Q2(I+1:N,I:M) from the right.
C
            CALL DCOPY( M-I+1, Q2(I,I), LDQ2, DWORK, 1 )
            IF ( I.LT.N ) THEN
               Q1(I,I) = ONE
               CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I),
     $                     Q1(I,I+1), LDQ1, DWORK(M+1) )
               CALL DLARF( 'Right', N-I, M-I+1, Q1(I,I), 1, TAU(I),
     $                     Q2(I+1,I), LDQ2, DWORK(M+1) )
            END IF
            IF ( I.LT.M )
     $         CALL DSCAL( M-I, -TAU(I), Q1(I+1,I), 1 )
            Q1(I,I) = ONE - TAU(I)
C
C           Set Q1(1:I-1,I) and Q2(I,1:M) to zero.
C
            DO 90 J = 1, I - 1
               Q1(J,I) = ZERO
   90       CONTINUE
            DO 100 J = 1, M
               Q2(I,J) = ZERO
  100       CONTINUE
C
C           Apply G(I) to Q1(I,I:N) from the left and to Q2(I:N,I)
C           from the right.
C
            CALL DROT( N-I+1, Q1(I,I), LDQ1, Q2(I,I), 1, CS(2*I-1),
     $                 CS(2*I) )
C
C           Apply H(I) to Q1(I:M,I:N) from the left and to Q2(I:N,I:M)
C           from the left.
C
            NU = DWORK(1)
            DWORK(1) = ONE
            CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q1(I,I),
     $                  LDQ1, DWORK(M+1) )
            CALL DLARF( 'Right', N-I+1, M-I+1, DWORK, 1, NU, Q2(I,I),
     $                  LDQ2, DWORK(M+1) )
  110    CONTINUE
      ELSE
         DO 140 I = K, 1, -1
C
C           Apply F(I) to Q1(I:M,I+1:N) and Q2(I:M,I+1:N) from the left.
C
            CALL DCOPY( M-I+1, Q2(I,I), 1, DWORK, 1 )
            IF ( I.LT.N ) THEN
               Q1(I,I) = ONE
               CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I),
     $                     Q1(I,I+1), LDQ1, DWORK(M+1) )
               CALL DLARF( 'Left', M-I+1, N-I, Q1(I,I), 1, TAU(I),
     $                     Q2(I,I+1), LDQ2, DWORK(M+1) )
            END IF
            IF ( I.LT.M )
     $         CALL DSCAL( M-I, -TAU(I), Q1(I+1,I), 1 )
            Q1(I,I) = ONE - TAU(I)
C
C           Set Q1(1:I-1,I) and Q2(1:M,I) to zero.
C
            DO 120 J = 1, I - 1
               Q1(J,I) = ZERO
  120       CONTINUE
            DO 130 J = 1, M
               Q2(J,I) = ZERO
  130       CONTINUE
C
C           Apply G(I) to Q1(I,I:N) and Q2(I,I:N) from the left.
C
            CALL DROT( N-I+1, Q1(I,I), LDQ1, Q2(I,I), LDQ2, CS(2*I-1),
     $                 CS(2*I) )
C
C           Apply H(I) to Q1(I:M,I:N) and Q2(I:M,I:N) from the left.
C
            NU = DWORK(1)
            DWORK(1) = ONE
            CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q1(I,I),
     $                  LDQ1, DWORK(M+1) )
            CALL DLARF( 'Left', M-I+1, N-I+1, DWORK, 1, NU, Q2(I,I),
     $                  LDQ2, DWORK(M+1) )
  140    CONTINUE
      END IF
      DWORK(1) = DBLE( MAX( 1, M+N ) )
C *** Last line of MB04WU ***
      END


program median_statistics
    use, intrinsic :: iso_fortran_env, only : error_unit, input_unit
    use :: median_stats_mod
    implicit none
    integer :: nr_values
    type(descriptive_stats_t) :: stats
    integer :: value_nr, istat
    character(len=2048) :: msg
    real :: data_value

    nr_values = get_command_llne_values()
    call init_stats(stats, nr_values)
    do value_nr = 1, nr_values
        read (unit=input_unit, fmt=*, iostat=istat, iomsg=msg) data_value
        if (istat == -1) then
            write (unit=error_unit, fmt='(2(A, I0))') &
                'warning: read ', get_nr_values(stats), ' values, expected ', nr_values
            exit
        end if
        if (istat /= 0) then
            write (unit=error_unit, fmt='(2A)') 'warning: ', trim(msg)
            cycle
        end if
        call add_value(stats, data_value)
    end do
    print '(A, I0)', 'n      = ', get_nr_values(stats)
    print '(A, F10.3)', 'mean   = ', get_mean(stats)
    print '(A, F10.3)', 'median   = ', get_median(stats)
    print '(A, F10.3)', 'stddev = ', get_stddev(stats)
    call finalize_stats(stats)

contains

    function get_command_llne_values() result(nr_values)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        integer :: nr_values
        character(len=1024) :: buffer

        if (command_argument_count() /= 1) then
            write (unit=error_unit, fmt='(A)') &
                'error: number of values required as argument'
            stop 5
        end if
        call get_command_argument(1, buffer)
        read (buffer, fmt=*) nr_values
    end function get_command_llne_values

end program median_statistics


***********************************************************************
c 	               ORBEL_XV2AEQ.F
***********************************************************************
*     PURPOSE:  Given the cartesian position and velocity of an orbit,
*       compute the osculating orbital elements a, e, and q only.
*
C       input:
c            x,y,z    ==>  position of object (real scalars)
c            vx,vy,vz ==>  velocity of object (real scalars)
c            gmsum       ==> G*(M1+M2) (real scalar)
c
c       Output:
c	     ialpha   ==> conic section type ( see PURPOSE, integer scalar)
C	     a        ==> semi-major axis or pericentric distance if a parabola
c                          (real scalar)
c            e        ==> eccentricity (real scalar)
c            q        ==> perihelion distance (real scalar); q = a(1 - e)
c
*     ALGORITHM: See e.g. p.70 of Fitzpatrick's "Priciples of Cel. Mech."
*     REMARKS: Based on M. Duncan's orbel_xv2el.f
*      This routine is generally applied to study (hyperbolic) close
c       encounters of test particles with planets.
*     AUTHOR:  L. Dones
*     DATE WRITTEN:  February 24, 1994
*     REVISIONS:
***********************************************************************

 	subroutine orbel_xv2aeq(x,y,z,vx,vy,vz,gmsum,
     &     ialpha,a,e,q)

      include '../swift.inc'

c...  Inputs Only:
	real*8 x,y,z,vx,vy,vz,gmsum

c...  Outputs
	integer ialpha
        real*8 a,e,q

c...  Internals:
        real*8 hx,hy,hz,h2,r,v2,energy,fac
c----
c...  Executable code

* Compute the angular momentum H, and thereby the inclination INC.

	hx = y*vz - z*vy
	hy = z*vx - x*vz
	hz = x*vy - y*vx
	h2 = hx*hx + hy*hy + hz*hz

*  Compute the radius R and velocity squared V2, and the dot
*  product RDOTV, the energy per unit mass ENERGY .

	r = sqrt(x*x + y*y + z*z)
	v2 = vx*vx + vy*vy + vz*vz
	energy = 0.5d0*v2 - gmsum/r

*  Determine type of conic section and label it via IALPHA
	if(abs(energy*r/gmsum) .lt. sqrt(TINY)) then
	   ialpha = 0
	else
	   if(energy .lt. 0.d0) ialpha = -1
	   if(energy .gt. 0.d0) ialpha = +1
	endif

* Depending on the conic type, determine the remaining elements
***
c ELLIPSE :
	if(ialpha .eq. -1) then
	  a = -0.5d0*gmsum/energy
	  fac = 1.d0 - h2/(gmsum*a)

         if (fac .gt. TINY) then
            e = sqrt ( fac )
	  else
	    e = 0.d0
	  endif

          q = a*(1.d0 - e)
          endif
***
***
c HYPERBOLA
	if(ialpha .eq. +1) then
	  a = +0.5d0*gmsum/energy
	  fac = h2/(gmsum*a)
          if (fac .gt. TINY) then
 	    e = sqrt ( 1.d0 + fac )
            q = -a*(1.d0 - e)
c     have to insert minus sign in expression for q because this code
c      takes a > 0, even for a hyperbola
	  else
c we only get here if a hyperbola is essentially a parabola
c so we calculate e accordingly to avoid singularities
	    e = 1.d0
            q = 0.5*h2/gmsum
	  endif
          endif
***
***
c PARABOLA : ( NOTE - in this case "a", which is formally infinite,
c         is arbitrarily set equal to the pericentric distance q).
	if(ialpha .eq. 0) then
	  a =  0.5d0*h2/gmsum
	  e = 1.d0
          q = a
	endif
***
***
	return
	end    ! orbel_xv2aeq
c------------------------------------------------------------------


SUBROUTINE HankelTransform( Nt, WKMin, WKDel, Stabil, RMin, NR, RDel, X, Y, Z, OPTION )

  !     Hankel Transform by series approximation - Currently first term only.
  !     Formulas from Abramowitz and Stegun, Eqs. 9.2.5-9.2.10
  !     X      = input k space spectra, Nt points.
  !     Z      = output transmission loss, Nr points.
  !     Nt     = number of points in transform.
  !     WKMin  = minimum wavenumber of input series.
  !     WKDel  = spacing of input series.
  !     Stabil = amount integration has been moved off of the real axis.
  !     Nr     = number of output transmission loss points.(WITH Nr < 2*Nt)
  !     RDel   = spacing of transmission loss points.
  !     RMin   = Starting point for TL

  !     Adapted from Steve Wales' original program

  IMPLICIT NONE
  REAL      pi, sqrt2pi
  COMPLEX   i, ipiD4
  PARAMETER ( i = (0.0, 1.0), pi = 3.141592653589793 )
  INTEGER   ir, ik, Nt, Nr
  REAL      R( Nr ), WKVEC( Nt ), RMin, WKMin, Rdel, WKdel, Stabil
  COMPLEX   X( Nt ), Y( Nt ), Z( Nr ), CK, iStab, iRMin
  CHARACTER (LEN=3) :: OPTION

  ! Initialization

  ipiD4   = i * pi / 4.0
  iStab   = i * Stabil
  iRMin   = i * RMin
  Sqrt2pi = 1.0 / SQRT ( 2. * pi )
  CK      = CMPLX ( +Stabil, -WKMin )

  ! Following should be pulled out of the subroutine for pre-computation
  ! It's here as a safety against passing an irregularly spaced vector

  R(     1 : Nr ) = RMin + [ ( IR, IR = 0, Nr - 1 ) ] * RDel
  WKVEC( 1 : Nt ) =        [ ( IK, IK = 0, Nt - 1 ) ] * WKDel

  IF ( WKMin > 0.5 * WKDel )  THEN
     X( 1 ) = WkDel * Sqrt2pi *                    SQRT( WKMin + iStab ) * X( 1 )
  ELSE
     X( 1 ) = 0.5 * ( iStab + WKDel ) * Sqrt2pi *  SQRT(         iStab ) * X( 1 )
  END IF
  X( 2 : Nt ) = WkDel * Sqrt2pi * SQRT(   WKMin + WKVEC( 2 : Nt )  + iStab ) * X( 2 : Nt )

  ! First term, lower-half of cosine transform
  IF ( OPTION(2 : 2) == 'P' .OR. OPTION(2 : 2) == 'B' ) THEN   ! (P)ositive or (B)oth positive and negative spectrum
     Y = X * EXP( -iRMin * WKVEC + ipiD4 )
     CALL CFFT( Y, Nt, 1 )                 ! EXP(-ikX) transform
     Z = Y( 1 : Nr ) * EXP ( CK * R )
  ENDIF

  !  Second term, second-half of cosine transform
  IF ( OPTION(2 : 2) == 'N' .OR. OPTION(2 : 2) == 'B' ) THEN   ! (N)egative or (B)oth positive and negative spectrum
     Y = X * EXP( +iRMin * WKVEC - ipiD4 )
     CALL CFFT( Y, Nt, -1 )                ! EXP(+ikX) transform
  ENDIF

  IF      ( OPTION(2 : 2) == 'B' ) THEN   ! both sides of spectrum
     Z = Z + Y( 1 : Nr ) * EXP ( -CK * R )
  ELSE IF ( OPTION(2 : 2) == 'N' ) THEN   ! negative spectrum only
     Z =     Y( 1 : Nr ) * EXP ( -CK * R )
  ENDIF

  IF ( OPTION(1 : 1) == 'R' ) Z = Z / SQRT( R )   ! cylindrical spreading

END SUBROUTINE HankelTransform

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

SUBROUTINE FourierTransform( Nt, WKMin, WKDel, Stabil, RMin, Nr, RDel, X, Y, Z )

  !     Fourier Transform
  !     X      = input k space spectra, Nt points.
  !     Z      = output transmission loss, Nr points.
  !     Nt     = number of points in transform.
  !     WKMin  = minimum wavenumber of input series.
  !     WKDel  = spacing of input series.
  !     Stabil = amount integration has been moved off of the real axis.
  !     Nr     = number of output transmission loss points.(WITH Nr <= 2*Nt)
  !     RDel   = spacing of transmission loss points.
  !     RMin   = Starting point for TL

  IMPLICIT NONE
  REAL      pi, sqrt2pi
  COMPLEX   i
  PARAMETER ( i = (0.0, 1.0), pi = 3.141592653589793 )
  INTEGER   ir, ik, Nt, Nr
  REAL      R( Nr ), WKVEC( Nt ), RMin, WKMin, Rdel, WKdel, Stabil
  COMPLEX   X( Nt ), Y( Nt ), Z( Nr ), CK, iStab, iRMin

  ! Initialization
  iStab   = i * Stabil
  iRMin   = i * RMin
  Sqrt2pi = 1. / SQRT ( 2. * pi )

  ! Following should be pulled out of the subroutine for pre-computation
  ! It's here as a safety against passing an irregularly spaced vector

  R(     1 : Nr ) = RMin + [ ( IR, IR = 0, Nr - 1 ) ] * RDel
  WKVEC( 1 : Nt ) =        [ ( IK, IK = 0, Nt - 1 ) ] * WKDel

  IF ( WKMin > 0.5 * WKDel )  THEN
     X( 1 ) = WKDel * Sqrt2pi * X( 1 )
  ELSE
     X( 1 ) = ( iStab + WKDel ) / 2.0 * Sqrt2pi * X( 1 )
  END IF
  X( 2 : Nt ) = WKDel * Sqrt2pi * X( 2 : Nt )

  ! First term, lower-half of cosine transform
  Y = X * EXP( -iRMin * WKVEC )
  CALL CFFT ( Y, Nt, +1 )                   ! EXP(-ikX) transform
  CK = CMPLX( +Stabil, -WKMin )
  Z =             Y( 1 : Nr ) * EXP ( CK * R )

  ! Second term, second-half of cosine transform
  Y = X * EXP( +iRMin * WKVEC )
  CALL CFFT( Y, Nt, -1 )                    ! EXP(+ikX) transform
  Z = Z( 1 : Nr ) + Y( 1 : Nr ) * EXP ( -CK * R )

END SUBROUTINE FourierTransform


MODULE poly_solvers
  USE iso_c_binding, only: c_double, c_double_complex, c_int
  IMPLICIT NONE

  real(c_double), parameter :: ZERO_TOLERANCE = 1.d-14
  real(c_double), parameter :: IMAG_TOLERANCE = 5.d-8
  real(c_double), parameter :: IMAG_TOLERANCE_SQRD = IMAG_TOLERANCE**2
  real(c_double), parameter :: PI = acos(-1.d0)
  real(c_double), parameter :: PIx2 = 2*PI
  complex(c_double_complex), dimension(3), parameter :: CUBE_ROOTS_OF_1 = (/ (1.d0, 0.d0), &
                                                                             exp(complex(0.d0, PIx2/3)), &
                                                                             exp(complex(0.d0, 2*PIx2/3)) /)

CONTAINS

  SUBROUTINE quartic_solve (Poly, out) BIND(C)
    implicit none
    real(c_double), dimension(5), intent(in) :: Poly
    double complex, dimension(4), intent(out) :: out
    real(c_double) :: e, d, c, b, bb, p, q, r, cc, dd, ee, ccc, Delta, Dee, Delta_0, Delta_1
    complex(c_double_complex) :: S, phi, zQ, SSx4, sqrtp, sqrtm
    complex(c_double_complex), dimension(3) :: S_v, SSx4_v
    integer(c_int) :: ir
    e = Poly(1) / Poly(5)
    d = Poly(2) / Poly(5)
    c = Poly(3) / Poly(5)
    b = Poly(4) / Poly(5)
    bb = b*b
    p = 0.125 * (8*c - 3*bb)
    q = 0.125 * (bb*b - 4*b*c + 8*d)
    r = (-3*bb*bb + 256*e - 64*b*d + 16*bb*c) / 256
    c = p
    d = q
    e = r
    cc = c*c
    dd = d*d
    ee = e*e
    ccc = cc*c
    Delta = -27*dd*dd - 128*cc*ee + 256*ee*e + 16*cc*cc*e + 144*c*dd*e - 4*ccc*dd
    Dee = 64*e - 16*cc
    Delta_0 = cc + 12*e
    Delta_1 = 2*ccc + 27*dd - 72*c*e
    if (Delta > 0 .and. p < 0 .and. Dee < 0) then
       phi = acos(Delta_1 / (2*sqrt(complex(Delta_0**3,0.d0))))
       S = 0.5 * sqrt((-2*p + 2*sqrt(complex(Delta_0,0.d0))*cos(phi/3))/3)
       SSx4 = 4*S*S
    else
       zQ = (0.5*(Delta_1 + sqrt(complex(-27*Delta,0.d0))))**(1.d0/3)
       SSx4_v = (-2*p + (zQ*CUBE_ROOTS_OF_1 + Delta_0/(zQ*CUBE_ROOTS_OF_1))) / 3.d0
       S_v = 0.5*sqrt(SSx4_v)
       if (Delta .ne. 0) then
          ir = maxloc(abs(S_v), 1)
          SSx4 = SSx4_v(ir)
          S = S_v(ir)
       else
          SSx4 = SSx4_v(1)
          S = S_v(1)
       endif
    endif
    sqrtp = sqrt(-SSx4 - 2*p + q/S)
    sqrtm = sqrt(-SSx4 - 2*p - q/S)
    out(1) = -0.25*b - S + 0.5*sqrtp;
    out(2) = -0.25*b - S - 0.5*sqrtp;
    out(3) = -0.25*b + S + 0.5*sqrtm;
    out(4) = -0.25*b + S - 0.5*sqrtm;
  END SUBROUTINE quartic_solve

  integer(c_int) function sort_complex_conjugate_pairs(roots) BIND(C)
    implicit none
    complex(c_double_complex), dimension(4), intent(inout) :: roots
    integer(c_int) :: npairs, i, j
    complex(c_double_complex) :: r, r_conj
    npairs = 0
    i = 1
    do while (i <= 3)
       r = roots(i)
       if (abs(DIMAG(r)) > IMAG_TOLERANCE) then
          do j = 1, 4-i
             r_conj = roots(i+j)
             if (       abs(DBLE(r) - DBLE(r_conj)) < ZERO_TOLERANCE &
                  .and. abs(DIMAG(r) + DIMAG(r_conj)) < ZERO_TOLERANCE) then
                roots(i) = roots(2*npairs+1)
                roots(i+j) = roots(2*npairs+2)
                roots(2*npairs+1) = r
                roots(2*npairs+2) = r_conj
                npairs = npairs + 1
                i = i + 1
                exit
             endif
          enddo
       endif
       i = i + 1
    enddo
    sort_complex_conjugate_pairs = npairs
  end function sort_complex_conjugate_pairs

  real(c_double) function find_min_quartic_root_in_real_interval(P, t0, t1) BIND(C)
    implicit none
    real(c_double), dimension(5), intent(in) :: P
    real(c_double), value, intent(in) :: t0, t1
    complex(c_double_complex), dimension(4) :: roots
    integer(c_int) :: npairs, i
    real(c_double) :: min_root
    complex(c_double_complex) :: r
    call quartic_solve(P, roots)
    min_root = huge(1.d0)
    npairs = sort_complex_conjugate_pairs(roots)
    do i = 2*npairs+1, 4
       r = roots(i)
       if (t0 < DBLE(r) .and. DBLE(r) < t1 &
            .and. DBLE(r) < min_root &
            .and. DIMAG(r)**2 / (DBLE(r)**2 + DIMAG(r)**2) < IMAG_TOLERANCE_SQRD) then
          min_root = DBLE(r)
       endif
    enddo
    find_min_quartic_root_in_real_interval = min_root
  end function find_min_quartic_root_in_real_interval

  real(c_double) function find_collision_time(a_i, a_j, R, t0, t1) BIND(C)
    implicit none
    real(c_double), dimension(3,3), intent(in) :: a_i, a_j
    real(c_double), value, intent(in) :: R, t0, t1
    real(c_double), dimension(3,3) :: a_ji
    real(c_double), dimension(0:4) :: P
    real(c_double), dimension(3) :: r_i, r_j, v_i, v_j, omega_i, omega_j
    real(c_double) :: t, v_ijy
    a_ji = a_i - a_j
    p(4) = dot_product(a_ji(:,3), a_ji(:,3))
    p(3) = 2 * dot_product(a_ji(:,3), a_ji(:,2))
    p(2) = dot_product(a_ji(:,2), a_ji(:,2)) + 2 * dot_product(a_ji(:,3), a_ji(:,1))
    p(1) = 2 * dot_product(a_ji(:,2), a_ji(:,1))
    p(0) = dot_product(a_ji(:,1), a_ji(:,1)) - 4*R*R
    ! PRINT *, "P =", P
    t = find_min_quartic_root_in_real_interval(P, t0, t1)
    if (t .ne. huge(1.d0)) then
       r_i = a_i(:,1) + t*a_i(:,2) + t**2*a_i(:,3)
       r_j = a_j(:,1) + t*a_j(:,2) + t**2*a_j(:,3)
       v_i = a_i(:,2) + 2*t*a_i(:,3)
       v_j = a_j(:,2) + 2*t*a_j(:,3)
       v_ijy = dot_product(v_j-v_i, r_j-r_i) / (2*R)
       if (v_ijy > 0) then
          ! PRINT *, "t =", t, " v_ijy =", v_ijy
          find_collision_time = huge(1.d0)
          return
       endif
    endif
    find_collision_time = t
  end function find_collision_time

END MODULE poly_solvers


C LINMEQ.F - Gateway function for solving Sylvester and Lyapunov matrix
C            equations using SLICOT routines SB04MD, SB04ND, SB04PD,
C            SB04QD, SB04RD, SB03MD, and SB03OD.
C
C RELEASE 2.0 of SLICOT Basic Systems and Control Toolbox.
C Based on SLICOT RELEASE 5.7. Copyright (c) 2002-2020 NICONET e.V.
C
C Matlab call:
C   [X(,sep)] = linmeq(task,A(,B),C,flag,trans(,schur))
C
C   task = 1 :      [X] = linmeq(1,A,B,C,flag,trans,schur)
C   task = 2 :  [X,sep] = linmeq(2,A,C,flag,trans)
C                   [X] = linmeq(2,A,C,flag,trans)
C   task = 3 :      [X] = linmeq(3,A,C,flag,trans)
C
C Purpose:
C   To solve the Sylvester and Lyapunov linear matrix equations
C
C   task = 1:
C
C         op(A)*X + X*op(B) = C,                          (1a)
C
C         op(A)*X*op(B) + X = C,                          (1b)
C
C   task = 2:
C
C         op(A)'*X + X*op(A) = C,                         (2a)
C
C         op(A)'*X*op(A) - X = C,                         (2b)
C
C   task = 3:
C
C         op(A)'*(op(X)'*op(X)) + (op(X)'*op(X))*op(A) =
C                               -  op(C)'*op(C),          (3a)
C
C         op(A)'*(op(X)'*op(X))*op(A) - op(X)'*op(X) =
C                                     - op(C)'*op(C),     (3b)
C
C   where op(M) = M, if trans = 0, and op(M) = M', if trans = 1.
C
C Input parameters:
C   task  - integer option to determine the equation type:
C           = 1 : solve the Sylvester equation (1a) or (1b);
C           = 2 : solve the Lyapunov equation (2a) or (2b);
C           = 3 : solve for the Cholesky factor op(X) the Lyapunov
C                 equation (3a) or (3b).
C   A     - real coefficient N-by-N matrix.
C           When task = 3, matrix A must be stable.
C   B     - another real coefficient M-by-M matrix for
C           equations (1a) or (1b).
C   C     - right hand side matrix.
C           task = 1 : C is N-by-M;
C           task = 2 : C is N-by-N symmetric;
C           task = 3 : op(C) is P-by-N.
C   flag  - (optional) integer vector of length 3 or 2 containing
C           options.
C           task = 1 : flag has length 3
C                flag(1) = 0 : solve the continuous-time equation (1a);
C                              otherwise, solve the discrete-time
C                              equation (1b).
C                flag(2) = 1 : A is (quasi) upper triangular;
C                          2 : A is upper Hessenberg;
C                              otherwise, A is in general form.
C                flag(3) = 1 : B is (quasi) upper triangular;
C                          2 : B is upper Hessenberg;
C                              otherwise, B is in general form.
C           task = 2 : flag has length 2
C                flag(1) = 0 : solve continuous-time equation (2a);
C                              otherwise, solve discrete-time
C                              equation (2b).
C                flag(2) = 1 : A is (quasi) upper triangular;
C                              otherwise, A is in general form.
C           task = 3 : flag has length 2
C                flag(1) = 0 : solve continuous-time equation (3a);
C                              otherwise, solve discrete-time
C                              equation (3b).
C                flag(2) = 1 : A is (quasi) upper triangular;
C                              otherwise, A is in general form.
C           Default:    flag(1) = 0, flag(2) = 0 (, flag(3) = 0).
C   trans - (optional) integer specifying a transposition option.
C           trans = 0 : solve the equations (1) - (3) with op(M) = M.
C           trans = 1 : solve the equations (1) - (3) with op(M) = M'.
C           trans = 2 : solve the equations (1) with op(A) = A',
C                                                    op(B) = B.
C           trans = 3 : solve the equations (1) with op(A) = A,
C                                                    op(B) = B'.
C           Default:    trans = 0.
C   schur - (optional) integer specifying whether the Hessenberg-Schur
C           or Schur method should be used.
C           Available for task = 1.
C           schur = 1 : Hessenberg-Schur method (one matrix is reduced
C                       to Schur form).
C           schur = 2 : Schur method (two matrices are reduced to Schur
C                       form).
C           Default:    schur = 1.
C
C Output parameters:
C   X     - solution of the equation (or its Cholesky factor for (3)).
C   sep   - (optional) estimator of Sep(op(A),-op(A)') for (2.a) or
C           Sepd(A,A') for (2.b).
C
C Comments:
C   1. For equation (1a) or (1b), when schur = 1, the Hessenberg-Schur
C      method is used, reducing one matrix to Hessenberg form and the
C      other one to a real Schur form.
C      Otherwise, both matrices are reduced to real Schur forms.
C      If one or both matrices are already reduced to Schur/Hessenberg
C      forms, this could be specified by flag(2) and flag(3).
C      For general matrices, the Hessenberg-Schur method could be
C      significantly more efficient than the Schur method.
C   2. For equation (3a) or (3b), the computed matrix X is the Cholesky
C      factor of the solution, i.e., the real solution is op(X)'*op(X),
C      where X is an N-by-N upper triangular matrix.
C
C Contributor:
C   H. Xu, TU Chemnitz, FR Germany, Dec. 1998.
C
C Revisions:
C   V. Sima, Katholieke Univ. Leuven, Belgium, May 1999.
C   V. Sima, Katholieke Univ. Leuven, Belgium, May 2000.
C   D. Sima, University of Bucharest, Romania, May 2000.
C   V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 2000.
C   V. Sima, Research Institute for Informatics, Bucharest, March 2006.
C   V. Sima, Research Institute for Informatics, Bucharest, Feb. 2009,
C   Apr. 2009, July 2011, Dec. 2012.
C
C **********************************************************************
C
C
      SUBROUTINE MEXFUNCTION( NLHS, PLHS, NRHS, PRHS )
C
C .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C
C .. Mex-file interface parameters ..
      INTEGER           PLHS(*), PRHS(*)
      INTEGER*4         NLHS, NRHS
C
C .. Mex-file integer functions ..
      INTEGER           mxCreateDoubleMatrix, mxGetPr
      INTEGER*4         mxGetM, mxGetN, mxIsNumeric, mxIsComplex
C
C .. Scalar parameters used by SLICOT subroutines ..
      CHARACTER         DICO, FACT, FACTA, FACTB, JOB, SCHU, TRANA,
     $                  TRANB, ULA, ULB
      INTEGER           INFO, ISGN, LDA, LDB, LDC, LDU, LDV, LDWORK, M,
     $                  N, P
      DOUBLE PRECISION  FERR, SCALE, SEP, TOL
C
C .. Allocatable arrays ..
C !Fortran 90/95 (Fixed dimensions should be used with Fortran 77.)
      INTEGER,          ALLOCATABLE :: IWORK(:)
      DOUBLE PRECISION, ALLOCATABLE :: A(:,:), B(:,:), C(:,:), DWORK(:),
     $                                 U(:,:), V(:,:), WR(:), WI(:)
C
C .. Local variables and constant dimension arrays ..
      CHARACTER*120     TEXT
      LOGICAL           BWORK(1), PERTRB
      INTEGER           FLAG(3), IB, IP, ISIZE, J, LDWO, LDW1, LDW2,
     $                  LIWORK, MC, MXMN, NB1, NB2, NC, NM, NSCHUR,
     $                  TASK, TRANS
      DOUBLE PRECISION  DUM(1), FLAGR(3), TEMP
C
C .. External functions ..
      LOGICAL           LSAME, SELECT
      INTEGER           ILAENV
      EXTERNAL          LSAME, ILAENV, SELECT
C
C .. External subroutines ..
      EXTERNAL          DLACPY, DGEES, DLASET, DSWAP, DTRSYL, SB03MD,
     $                  SB03OD, SB04MD, SB04ND, SB04PD, SB04PY, SB04QD,
     $                  SB04RD
C
C ..Intrinsic functions..
      INTRINSIC         MAX, MIN
C
C Check for proper number of arguments.
C
      IF ( NRHS.LT.3 ) THEN
         CALL mexErrMsgTxt
     $        ( 'LINMEQ requires at least 3 input arguments' )
      ELSE IF ( NLHS.GT.2 ) THEN
         CALL mexErrMsgTxt
     $        ( 'LINMEQ requires at most 2 output arguments' )
      END IF
C
C Check dimensions of input parameters and read/set scalar parameters.
C
C   task
C
      IF ( mxGetM( PRHS(1) ).NE.1 .OR. mxGetN( PRHS(1) ).NE.1 ) THEN
         CALL mexErrMsgTxt( 'TASK must be a scalar' )
      END IF
      IF ( mxIsNumeric( PRHS(1) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(1) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'TASK must be an integer scalar' )
      END IF
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(1) ), TEMP, 1 )
      TASK = TEMP
      IF ( TASK.LT.1 .OR. TASK.GT.3 ) THEN
         CALL mexErrMsgTxt
     $        ( 'TASK has 1, 2, or 3 the only admissible values' )
      END IF
C
      IF ( TASK.EQ.1 ) THEN
         IF ( NRHS.LT.4 ) THEN
            CALL mexErrMsgTxt
     $          ( 'LINMEQ requires at least 4 input arguments' )
         END IF
         IP = 6
      ELSE
         IP = 5
      END IF
C
C   trans
C
      TRANS = 0
      IF ( NRHS.GE.IP ) THEN
         ISIZE = mxGetM( PRHS(IP) ) * mxGetN( PRHS(IP) )
         IF ( ISIZE.GT.1 ) THEN
            CALL mexErrMsgTxt( 'TRANS must be a scalar' )
         END IF
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'TRANS must be an integer scalar' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), TEMP, ISIZE )
         IF ( ISIZE.GT.0 ) TRANS = TEMP
         IF ( TASK.EQ.1 .AND. ( TRANS.LT.0 .OR. TRANS.GT.3 ) ) THEN
            CALL mexErrMsgTxt
     $         ( 'TRANS has 0, 1, 2, or 3 the only admissible values' )
         ELSE IF ( TASK.NE.1 .AND. ( TRANS.LT.0 .OR. TRANS.GT.1 ) ) THEN
            CALL mexErrMsgTxt
     $         ( 'TRANS has 0, or 1 the only admissible values' )
         END IF
      END IF
C
C   schur
C
      IF ( TASK.EQ.1 ) THEN
         NSCHUR = 1
         IF ( NRHS.EQ.IP+1 ) THEN
            ISIZE = mxGetM( PRHS(IP+1) ) * mxGetN( PRHS(IP+1) )
            IF ( ISIZE.GT.1 ) THEN
               CALL mexErrMsgTxt( 'SCHUR must be a scalar' )
            END IF
            IF ( mxIsNumeric( PRHS(IP+1) ).EQ.0 .OR.
     $           mxIsComplex( PRHS(IP+1) ).EQ.1 ) THEN
               CALL mexErrMsgTxt( 'SCHUR must be an integer scalar' )
            END IF
            CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP+1) ), TEMP, ISIZE )
            IF ( ISIZE.GT.0 ) NSCHUR = TEMP
            IF ( NSCHUR.LT.1 .OR. NSCHUR.GT.2 ) THEN
               CALL mexErrMsgTxt
     $              ( 'SCHUR has 1, or 2 the only admissible values' )
            END IF
         END IF
      ELSE
         NSCHUR = 0
      END IF
C
C   A(NxN), (B(MxM),) C(NxM), or C(NxN), or op(C)(PxN)
C
      N = mxGetM( PRHS(2) )
      IF ( TASK.EQ.1 ) THEN
         M = mxGetM( PRHS(3) )
      ELSE IF ( TASK.EQ.3 ) THEN
         IF ( TRANS.EQ.0 ) THEN
            P = mxGetM( PRHS(3) )
         ELSE
            P = mxGetN( PRHS(3) )
         END IF
      END IF
C
      IF ( mxGetN( PRHS(2) ).NE.N ) THEN
         CALL mexErrMsgTxt( 'A must be a square matrix' )
      END IF
      IF ( mxIsNumeric( PRHS(2) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(2) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'A must be a real matrix' )
      END IF
C
      IP = 3
      IF ( TASK.EQ.1 ) THEN
C
         IF ( mxGetN( PRHS(IP) ).NE.M ) THEN
            CALL mexErrMsgTxt( 'B must be a square matrix' )
         END IF
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'B must be a real matrix' )
         END IF
         IP = IP + 1
      END IF
C
      MC = mxGetM( PRHS(IP) )
      NC = mxGetN( PRHS(IP) )
C
      IF ( TASK.NE.3 ) THEN
C
         IF ( MC.NE.N ) THEN
            CALL mexErrMsgTxt
     $           ( 'C must have the same row dimension as A' )
         END IF
         IF ( TASK.EQ.1 ) THEN
            IF ( NC.NE.M )
     $         CALL mexErrMsgTxt
     $              ( 'C must have the same column dimension as B' )
         ELSE
            IF ( NC.NE.N )
     $         CALL mexErrMsgTxt
     $              ( 'C must have the same column dimension as A' )
         END IF
C
      ELSE
C
         IF ( TRANS.EQ.0 ) THEN
            IF ( NC.NE.N )
     $         CALL mexErrMsgTxt
     $              ( 'C must have the same column dimension as A' )
         ELSE
            IF ( MC.NE.N )
     $         CALL mexErrMsgTxt
     $              ( 'C must have the same row dimension as A' )
         END IF
C
      END IF
C
      IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $     mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
         CALL mexErrMsgTxt( 'C must be a real matrix' )
      END IF
      IP = IP + 1
C
      FLAG(1) = 0
      FLAG(2) = 0
      FLAG(3) = 0
      IF ( NRHS.GE.IP ) THEN
C
C   flag
C
         ISIZE = mxGetM( PRHS(IP) ) * mxGetN( PRHS(IP) )
         IF ( TASK.EQ.1 ) THEN
            IF ( ISIZE.GT.3 )
     $         CALL mexErrMsgTxt
     $              ( 'FLAG must be a vector with at most 3 elements' )
         ELSE
            IF ( ISIZE.GT.2 )
     $         CALL mexErrMsgTxt
     $              ( 'FLAG must be a vector with at most 2 elements' )
         END IF
         IF ( mxIsNumeric( PRHS(IP) ).EQ.0 .OR.
     $        mxIsComplex( PRHS(IP) ).EQ.1 ) THEN
            CALL mexErrMsgTxt( 'FLAG must be a real vector' )
         END IF
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(IP) ), FLAGR, ISIZE )
         IF ( ISIZE.GT.0 ) FLAG(1) = FLAGR(1)
         IF ( ISIZE.GT.1 ) FLAG(2) = FLAGR(2)
         IF ( ISIZE.GT.2 ) FLAG(3) = FLAGR(3)
      END IF
      IF ( FLAG(2).NE.0 .AND. FLAG(2).NE.1 ) THEN
         IF ( TASK.NE.1 .OR. ( TASK.EQ.1 .AND. FLAG(2).NE.2 ) )
     $      FLAG(2) = 0
      END IF
      IF ( TASK.EQ.1 .AND. ( FLAG(3).LT.0 .OR. FLAG(3).GT.2 ) )
     $   FLAG(3) = 0
C
C Determine the lenghts of working arrays.
C Use a value for LDWORK enabling calls of block algorithms
C in DGEES, and possibly in DGEHRD, DGEQRF, DGERQF, SB04PD.
C
      LDA = MAX( 1, N )
      IF ( NSCHUR.NE.1 ) THEN
         IP = N
      ELSE
         IP = M
      END IF
      IF ( FLAG(2).NE.1 ) THEN
         IF ( TASK.NE.1 .OR. ( TASK.EQ.1 .AND. NSCHUR.EQ.2 ) ) THEN
            CALL DGEES( 'Vectors', 'No sort', SELECT, IP, DUM,
     $                  MAX( 1, IP ), IP, DUM, DUM, DUM, MAX( 1, IP ),
     $                  DUM, -1, BWORK, INFO )
            LDWO = DUM(1)
         ELSE
            LDWO = 0
         END IF
      ELSE
         LDWO = 0
      END IF
      IF ( TASK.EQ.1 ) THEN
         LDB = MAX( 1, M )
         IF ( NSCHUR.EQ.2 ) THEN
C
C           Need    LDWORK = MAX( 1, LDW1 + LDW2 ) with LDWO = 0.
C           Prefer  larger.
C
            IF ( FLAG(2).EQ.1 ) THEN
               LDW1 = 0
               LDW2 = 0
            ELSE
               LDW1 = 3*N + 1
               LDW2 = 2*N + LDWO
            END IF
            IB = 0
            IF ( FLAG(3).NE.1 ) THEN
               IB = 2*M
               IF ( FLAG(2).EQ.1 )
     $            IB = IB + 1
               IF ( FLAG(3).NE.2 ) THEN
                  CALL DGEES( 'Vectors', 'No sort', SELECT, M, DUM, LDB,
     $                        IP, DUM, DUM, DUM, LDB, DUM, -1, BWORK,
     $                        INFO )
                  LDWO = DUM(1)
               END IF
               LDW2 = MAX( LDW2, MAX( IB + M, LDWO ) + 2*M )
            END IF
            LDW2   = MAX( LDW2, IB + 2*N )
            LDWORK = MAX( 1, LDW1 + LDW2 )
            IF ( FLAG(2)*FLAG(3).NE.1 ) THEN
     $         LDWORK = MAX( LDWORK, LDW1 - N + IB + M*N )
         ELSE
            IF ( FLAG(2)*FLAG(3).EQ.1 ) THEN
               LIWORK = 0
               IF ( FLAG(1).NE.0 ) THEN
                  LDWORK = 2*N
               ELSE
                  LDWORK = 0
               END IF
            ELSE IF ( FLAG(2)*FLAG(3).EQ.2 ) THEN
               MXMN   = MAX( M, N )
               LIWORK = 2*MXMN
               LDWORK = 2*MXMN*( 4 + 2*MXMN )
            ELSE
               LIWORK = 4*N
               LDWORK = MAX( 1, 5*M, N + M )
               IF ( FLAG(1).EQ.0 ) THEN
                  LDWORK = MAX( LDWORK, 2*N*N + 8*N )
               ELSE
                  LDWORK = MAX( LDWORK, 2*N*N + 9*N )
               END IF
C
C              Need    LDWORK above.
C              Prefer  LDWORK below.
C
               LDWORK = MAX( LDWORK, 2*M + LDWO, N + N*M, N +
     $                       N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 ),
     $                       N +
     $                       M*ILAENV( 1, 'DORMQR', 'LT', N, M, N, -1 ),
     $                       N +
     $                       M*ILAENV( 1, 'DORMQR', 'LN', N, M, N, -1 )
     $                     )
            END IF
         END IF
         NM = M
C
      ELSE IF ( TASK.EQ.2 ) THEN
C
C        Need    LDWORK = MAX( 1, N*N, 3*N )
C        Prefer  larger.
C
         LDWORK = MAX( 1, N*N, 3*N, LDWO )
         IF ( NLHS.EQ.2 ) THEN
            LDWORK = MAX( LDWORK, 2*N*N )
            IF ( FLAG(1).NE.0 )
     $         LDWORK = MAX( LDWORK, 2*( N*N + N ) )
         END IF
         NM = N
      END IF
      IF ( TASK.NE.3 ) THEN
         LDC = LDA
      ELSE
         IF ( TRANS.EQ.0 ) THEN
            LDC = MAX( 1, N, P )
         ELSE
            LDC = LDA
         END IF
         MXMN = MIN( P, N )
C
C        Need    LDWORK = MAX( 1, 4*N + MXMN )
C        Prefer  larger.
C
         IF ( TRANS.EQ.0 ) THEN
            NB1 = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
            NB2 = ILAENV( 1, 'DGEQRF', ' ', N, N, -1, -1 )
         ELSE
            NB1 = ILAENV( 1, 'DGERQF', ' ', N, M, -1, -1 )
            NB2 = ILAENV( 1, 'DGERQF', ' ', N, N, -1, -1 )
         END IF
         LDWORK = MAX( 1, MAX( LDWO, MXMN + MAX( N*NB1, 4*N ), N*MXMN,
     $                         N*N, N + N*NB2 ) )
         NM = N
      END IF
C
C Allocate variable dimension local arrays.
C !Fortran 90/95
C
      IF ( TASK.EQ.1 ) THEN
         ALLOCATE ( A( LDA, N ), B( LDB, M ), C( LDC, M ) )
         ALLOCATE ( DWORK( LDWORK ) )
         IF ( NSCHUR.EQ.2 ) THEN
            IF ( FLAG(2).EQ.1 ) THEN
               FACTA = 'S'
               LDU   = 1
               ALLOCATE ( U( LDU, 1 ) )
            ELSE
               FACTA = 'N'
               LDU   = LDA
               ALLOCATE ( U( LDU, N ) )
            END IF
            IF ( FLAG(3).EQ.1 ) THEN
               FACTB = 'S'
               LDV   = 1
               ALLOCATE ( V( LDV, 1 ) )
            ELSE
               FACTB = 'N'
               LDV   = LDB
               ALLOCATE ( V( LDV, M ) )
            END IF
         ELSE
            SCHU = 'N'
            ALLOCATE ( IWORK( LIWORK ) )
            IF ( FLAG(2).EQ.1 ) THEN
               IF ( FLAG(3).EQ.1 ) THEN
                  SCHU = 'S'
               ELSE IF ( FLAG(3).EQ.2 ) THEN
                  SCHU = 'A'
               END IF
            ELSE IF ( FLAG(2).EQ.2 .AND. FLAG(3).EQ.1 ) THEN
               SCHU = 'B'
            END IF
C
            IF ( LSAME( SCHU, 'N' ) ) THEN
               LDU = LDB
               ALLOCATE ( U( LDU, M ) )
            END IF
         END IF
C
      ELSE IF ( TASK.EQ.2 ) THEN
         LDU = LDA
         ALLOCATE ( A( LDA, N ), C( LDC, N ), U( LDU, N ) )
         ALLOCATE ( DWORK( LDWORK ), WI( N ), WR( N ) )
         IF ( NLHS.EQ.1 ) THEN
            ALLOCATE ( IWORK( 1 ) )
         ELSE
            ALLOCATE ( IWORK( N*N ) )
         END IF
      ELSE
         IF ( TRANS.EQ.0 ) THEN
            ALLOCATE ( A( LDA, N ), C( LDC, N ) )
         ELSE
            ALLOCATE ( A( LDA, N ), C( LDC, MAX( P, N ) ) )
         END IF
         LDU = LDA
         ALLOCATE ( U( LDU, N ), DWORK( LDWORK ), WI( N ), WR( N ) )
      END IF
C
C Copy inputs from MATLAB workspace to locally allocated arrays.
C
      IF ( TASK.EQ.3 ) THEN
         IF ( P.GE.N .OR. TRANS.NE.0 ) THEN
            CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), C, P*N )
         ELSE
C
C           P < N and trans = 0. Use A temporarily for loading C.
C
            CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), A, P*N )
            CALL DLACPY( 'Full', P, N, A, MAX( 1, P ), C, LDC )
         END IF
      END IF
      CALL mxCopyPtrToReal8( mxGetPr( PRHS(2) ), A, N*N )
      IF ( TASK.EQ.1 ) THEN
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), B, M*M )
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(4) ), C, N*M )
      ELSE IF ( TASK.EQ.2 ) THEN
         CALL mxCopyPtrToReal8( mxGetPr( PRHS(3) ), C, N*N )
      END IF
C
C Do the actual computations.
C
      IF ( TASK.EQ.1 ) THEN
C
         IF ( NSCHUR.EQ.2 ) THEN
            IF ( TRANS.EQ.0 ) THEN
               TRANA = 'N'
               TRANB = 'N'
            ELSE IF ( TRANS.EQ.1 ) THEN
               TRANA = 'T'
               TRANB = 'T'
            ELSE IF ( TRANS.EQ.2 ) THEN
               TRANA = 'T'
               TRANB = 'N'
            ELSE IF ( TRANS.EQ.3 ) THEN
               TRANA = 'N'
               TRANB = 'T'
            END IF
            IF ( FLAG(1).NE.0 ) THEN
               DICO = 'D'
            ELSE
               DICO = 'C'
            END IF
            ISGN = 1
            CALL SB04PD( DICO, FACTA, FACTB, TRANA, TRANB, ISGN, N, M,
     $                   A, LDA, U, LDU, B, LDB, V, LDV, C, LDC, SCALE,
     $                   DWORK, LDWORK, INFO )
         ELSE
            IF ( TRANS.EQ.0 ) THEN
               IF ( LSAME( SCHU, 'S' ) ) THEN
                  TRANA = 'N'
                  TRANB = 'N'
               ELSE
                  ULA = 'U'
                  ULB = 'U'
               END IF
            ELSE IF ( TRANS.EQ.1 ) THEN
               IF ( LSAME( SCHU, 'S' ) ) THEN
                  TRANA = 'T'
                  TRANB = 'T'
               ELSE
                  ULA = 'L'
                  ULB = 'L'
                  DO 10 J = 2, N
                     CALL DSWAP( J-1, A( 1, J ), 1, A( J, 1 ), LDA )
   10             CONTINUE
                  DO 20 J = 2, M
                     CALL DSWAP( J-1, B( 1, J ), 1, B( J, 1 ), LDB )
   20             CONTINUE
               END IF
            ELSE IF ( TRANS.EQ.2 ) THEN
               IF ( LSAME( SCHU, 'S' ) ) THEN
                  TRANA = 'T'
                  TRANB = 'N'
               ELSE
                  ULA = 'L'
                  ULB = 'U'
                  DO 30 J = 2, N
                     CALL DSWAP( J-1, A( 1, J ), 1, A( J, 1 ), LDA )
   30             CONTINUE
               END IF
            ELSE IF ( TRANS.EQ.3 ) THEN
               IF ( LSAME( SCHU, 'S' ) ) THEN
                  TRANA = 'N'
                  TRANB = 'T'
               ELSE
                  ULA = 'U'
                  ULB = 'L'
                  DO 40 J = 2, M
                     CALL DSWAP( J-1, B( 1, J ), 1, B( J, 1 ), LDB )
   40             CONTINUE
               END IF
            END IF
C
            IF ( LSAME( SCHU, 'N' ) ) THEN
C
               SCALE = ONE
               IF ( FLAG(1).EQ.0 ) THEN
                  CALL SB04MD( N, M, A, LDA, B, LDB, C, LDC, U, LDU,
     $                         IWORK, DWORK, LDWORK, INFO )
               ELSE
                  CALL SB04QD( N, M, A, LDA, B, LDB, C, LDC, U, LDU,
     $                         IWORK, DWORK, LDWORK, INFO )
               END IF
C
            ELSE IF ( LSAME( SCHU, 'S' ) ) THEN
C
               IF ( FLAG(1).EQ.0 ) THEN
                  CALL DTRSYL( TRANA, TRANB, 1, N, M, A, LDA, B, LDB, C,
     $                         LDC, SCALE, INFO )
                  IF ( MIN( N, M ).EQ.0 )
     $               SCALE = ONE
               ELSE
                  CALL SB04PY( TRANA, TRANB, 1, N, M, A, LDA, B, LDB, C,
     $                         LDC, SCALE, DWORK, INFO )
               END IF
            ELSE
               SCALE = ONE
               TOL   = ZERO
C
C              Default tolerance (epsilon_machine) is used.
C
               IF ( FLAG(1).EQ.0 ) THEN
                  CALL SB04ND( SCHU, ULA, ULB, N, M, A, LDA, B, LDB, C,
     $                         LDC, TOL, IWORK, DWORK, LDWORK, INFO )
               ELSE
                  CALL SB04RD( SCHU, ULA, ULB, N, M, A, LDA, B, LDB, C,
     $                         LDC, TOL, IWORK, DWORK, LDWORK, INFO )
               END IF
C
            END IF
         END IF
C
      ELSE
C
         IF ( FLAG(1).EQ.0 ) THEN
            DICO = 'C'
         ELSE
            DICO = 'D'
         END IF
         IF ( FLAG(2).NE.1 ) THEN
            FACT = 'N'
         ELSE
            FACT = 'F'
            CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU )
         END IF
C
         IF ( TRANS.EQ.0 ) THEN
            TRANA = 'N'
         ELSE
            TRANA = 'T'
         END IF
C
         IF ( TASK.EQ.2 ) THEN
            IF ( NLHS.EQ.2 ) THEN
               JOB = 'B'
            ELSE
               JOB = 'X'
            END IF
C
            CALL SB03MD( DICO, JOB, FACT, TRANA, N, A, LDA, U, LDU,
     $                   C, LDC, SCALE, SEP, FERR, WR, WI, IWORK,
     $                   DWORK, LDWORK, INFO )
C
         ELSE
C
            CALL SB03OD( DICO, FACT, TRANA, N, P, A, LDA, U, LDU,
     $                   C, LDC, SCALE, WR, WI, DWORK, LDWORK, INFO )
C
         END IF
      END IF
C
C Copy output to MATLAB workspace.
C
      PERTRB = ( TASK.EQ.1 .AND. ( INFO.EQ.N+M+1 .OR.
     $         ( FLAG(2)*FLAG(3).EQ.1 .AND. INFO.EQ.1 ) ) )
     $    .OR. ( TASK.EQ.2 .AND. INFO.EQ.N+1 )
     $    .OR. ( TASK.EQ.3 .AND. INFO.EQ.1 )
      IF ( INFO.EQ.0 .OR. PERTRB ) THEN
         IF ( NLHS.GE.1 ) THEN
            IF ( TASK.EQ.3 ) THEN
               IF ( TRANS.EQ.0 .AND. P.GT.N )
     $            CALL DLACPY( 'Upper', N, N, C, LDC, C, LDA )
               IF ( N.GT.1 )
     $            CALL DLASET( 'Lower', N-1, N-1, ZERO, ZERO, C(2,1),
     $                         LDA )
            END IF
            PLHS(1) = mxCreateDoubleMatrix( N, NM, 0 )
            CALL mxCopyReal8ToPtr( C, mxGetPr( PLHS(1) ), N*NM )
         END IF
C
         IF ( TASK.EQ.2 ) THEN
            IF ( NLHS.GE.2 ) THEN
               IF ( N.EQ.ZERO )
     $            SEP = ZERO
               PLHS(2) = mxCreateDoubleMatrix( 1, 1, 0 )
               CALL mxCopyReal8ToPtr( SEP, mxGetPr( PLHS(2) ), 1 )
            END IF
         END IF
      END IF
C
C Deallocate local arrays.
C !Fortran 90/95
C
      IF ( TASK.EQ.1 ) THEN
         DEALLOCATE( A, B, C, DWORK )
         IF ( NSCHUR.EQ.2 ) THEN
            DEALLOCATE ( U, V )
         ELSE
            DEALLOCATE( IWORK )
            IF ( LSAME( SCHU, 'N' ) )
     $         DEALLOCATE ( U )
         END IF
      ELSE IF ( TASK.EQ.2 ) THEN
         DEALLOCATE( A, C, U, WR, WI, IWORK, DWORK )
      ELSE
         DEALLOCATE( A, C, U, WR, WI, DWORK )
      END IF
C
C Error and warning handling.
C
      IF ( INFO.NE.0 ) THEN
         IF ( TASK.EQ.1 ) THEN
            IF ( NSCHUR.EQ.2 ) THEN
               WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM SB04PD'')'
     $              ) INFO
            ELSE
               IF ( LSAME( SCHU, 'N' ) ) THEN
                  IF ( FLAG(1).EQ.0 ) THEN
                     WRITE( TEXT, '('' INFO = '',I4,
     $                      '' ON EXIT FROM SB04MD'')' ) INFO
                  ELSE
                     WRITE( TEXT, '('' INFO = '',I4,
     $                      '' ON EXIT FROM SB04QD'')' ) INFO
                  END IF
               ELSE IF ( LSAME( SCHU, 'S' ) ) THEN
                  IF ( FLAG(1).EQ.0 ) THEN
                     WRITE( TEXT, '('' INFO = '',I4,
     $                      '' ON EXIT FROM DTRSYL'')' ) INFO
                  ELSE
                     WRITE( TEXT, '('' INFO = '',I4,
     $                      '' ON EXIT FROM SB04PY'')' ) INFO
                  END IF
               ELSE
                  IF ( FLAG(1).EQ.0 ) THEN
                     WRITE( TEXT, '('' INFO = '',I4,
     $                      '' ON EXIT FROM SB04ND'')' ) INFO
                  ELSE
                     WRITE( TEXT, '('' INFO = '',I4,
     $                      '' ON EXIT FROM SB04RD'')' ) INFO
                  END IF
               END IF
            END IF
         ELSE IF ( TASK.EQ.2 ) THEN
            WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM SB03MD'')'
     $           ) INFO
         ELSE
            WRITE( TEXT, '('' INFO = '',I4,'' ON EXIT FROM SB03OD'')' )
     $             INFO
         END IF
      END IF
C
      IF ( ( INFO.EQ.0 .OR. PERTRB ) .AND. SCALE.NE.ONE ) THEN
         IF ( TASK.LE.2 ) THEN
            TEMP = SCALE
         ELSE
            TEMP = SCALE**2
         END IF
         WRITE ( TEXT, '( '' Warning: The right hand sides were '',
     $      ''scaled by'', D13.6, '' to avoid overflow. '' )' ) TEMP
      END IF
C
      IF ( INFO.NE.0 .AND. .NOT.PERTRB ) THEN
         CALL mexErrMsgTxt( TEXT )
      ELSE IF ( SCALE.NE.ONE ) THEN
         CALL mexPrintf( TEXT )
      END IF
      IF ( PERTRB ) THEN
         WRITE ( TEXT, '( '' Warning: The equation is (almost) '',
     $      ''singular; perturbed values have been used. '' )' )
         CALL mexPrintf( TEXT )
      END IF
C
      RETURN
C *** Last line of LINMEQ ***
      END


program halfmerged

USE DISPMODULE
!USE omp_lib

IMPLICIT NONE

include '/usr/local/include/fftw3.f'

INTEGER, PARAMETER :: Nx=156,Ny=32,Nz=28,Lx= 30,Ly=6,Nstep=1
REAL, PARAMETER:: pi=3.1415926535897932384626433832795028841971693993,Re=10,vis=1/Re,dt=1e-3,&
xi_x=2*pi/Lx,yi_y=2*pi/Ly,Lz=4,eta_zgl=2/Lz,eta_zg=2/Lz
INTEGER(KIND=4):: l,m,oo, pivot(Nz+1), pivott(Nz),ok,vandrow,vandcol,j,k,h,n,tt,planf,planb,count,iol
COMPLEX,PARAMETER::i = (0.0,1.0)
COMPLEX, DIMENSION(Nz+1,3):: BB
REAL ,DIMENSION(Nz+1):: zgl,etagl
REAL ,DIMENSION(Nz):: zg,etag
REAL ,DIMENSION(Nx):: x,kx
REAL, DIMENSION(Ny):: y,ky
REAL ,DIMENSION(Nz,Nz)::VetaG,dVetaG,ARAVG,DIAG1VG,DIAG2VG,Ig,invVG,Detag,&
VGforinv,div_x_act_on_grad_x,&
div_z_act_on_grad_z
REAL ,DIMENSION(Nz+1,Nz+1)::Vetagl,dVetagl,DIAG1,ARAVGLeta,DIAG2,Dgl,&
ZNz,ZNx,Igldt,Iglvis,invVGL,&
Igl,VGLforinv,D2etagl,Detagl
COMPLEX ,DIMENSION(Nz+1,Nz+1)::A
COMPLEX, DIMENSION(Nz+1):: convectiveu,rhsuint,convectivev,rhsvint,&
convectivew,rhswint,ustar,vstar,wstar
real ( kind = 8 ), DIMENSION(Ny,Nx,Nz+1):: temp
complex ( kind = 8 ), DIMENSION(Ny,Nx,Nz+1):: ududxh,vdudyh,wdudzh,ududxoldh,vdudyoldh,wdudzoldh,&
uh,uoldh,vdvdyh,udvdxh,wdvdzh,udvdxoldh,vdvdyoldh,wdvdzoldh,&
vdwdyh,udwdxh,wdwdzh,udwdxoldh,vdwdyoldh,wdwdzoldh,unewh,vnewh,wnewh,vh,voldh,wh,woldh,f,&
fh,u,v,w,uold,vold,wold,dudxh,dvdxh,dwdxh,dudxoldh,dvdxoldh,dwdxoldh,&
dudyh,dvdyh,dwdyh,dudyoldh,dvdyoldh,dwdyoldh,&
dudx,dudz,dvdx,dvdz,dwdx,dwdz,dudxold,dudzold,dvdxold,dvdzold,dwdxold,dwdzold,&
ududx,udvdx,udwdx,ududxold,udvdxold,udwdxold,&
wdvdz,wdudz,wdwdz,wdudzold,wdvdzold,wdwdzold,dudy,dudyold,dvdy,dvdyold,dwdy,dwdyold,&
vdudy,vdudyold,vdvdy,vdvdyold,vdwdy,vdwdyold,unew,vnew,wnew,contcont,savearray
COMPLEX, DIMENSION(Nz,Nz):: LHS
COMPLEX, DIMENSION(Nz):: RHS
COMPLEX, DIMENSION(Ny,Nx,Nz):: pnewh
REAL ,DIMENSION(Nz,Nz+1)::VG_trunc,div_x,div_z
REAL ,DIMENSION(Nz+1,Nz)::grad_x,grad_z
COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE :: inf,outf
 CHARACTER*100 :: name_config,action,file
real :: start1, finish1,startloop,finishloop,start2, finish2,start3, finish3,start,finish,start4, finish4,start5, finish5
real :: startstart,finishfinish
INTEGER(kind=4)      :: rank,idist,odist,istride,ostride,howmany
integer,dimension(2)::ppp,inembed,onembed
INTEGER   :: numthreads,ierr

call cpu_time(start1)
!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! REQUIRED OPERATORS MODES,GRID!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!
! X,Y Coordinates
do j=1,Nx;x(j)=(((2*pi)/Nx)*(j-1))/xi_x;end do
do j=1,Ny;y(j)=(((2*pi)/Ny)*(j-1))/yi_y;end do
! Z COORDINATES- GAUSS & GL zg/zgl coord.
DO vandrow=1,Nz+1;etagl(vandrow)=-cos(pi*(vandrow-1)/Nz);END DO; zgl=(etagl+1)/eta_zgl;
DO vandrow=1,Nz;  etag(vandrow)=-cos(pi*(vandrow-0.5)/Nz);END DO; zg=(etag+1)/eta_zg;
! X,Y modes-k's
DO l=1,Nx/2;kx(l)=l-1;ENDDO;DO l=1,Nx/2;kx(l+Nx/2)=-Nx/2+l-1;ENDDO
DO l=1,Ny/2;ky(l)=l-1;ENDDO;DO l=1,Ny/2;ky(l+Ny/2)=-Ny/2+l-1;ENDDO
! VANDERMONDE MATRICES REQUIRED TO CONSTRUCT CHEBYSHEV DIFFERENTIATION MATRICES
!GAUSS LOBATTO dVGL
do vandrow=1,Nz+1;  do vandcol=1,Nz+1;
 Vetagl(vandrow,vandcol)=cos(acos(etagl(vandrow))*(vandcol-1));
 ARAVGLeta(vandrow,vandcol)=sin(acos(etagl(vandrow))*(vandcol-1));
end do ;end do
 DIAG1=0.0;DIAG2=0.0;
do vandcol=1,Nz+1;DIAG2(vandcol,vandcol)=vandcol-1;  end do
do vandcol=2,Nz;DIAG1(vandcol,vandcol)=1/SQRT(1-etagl(vandcol)**2);  end do
 dVetagl=MATMUL(DIAG1,ARAVGLeta)
 dVetagl=MATMUL(dVetagl,DIAG2)
do j=1,Nz+1;  dVetagl(1,j)=((-1)**j)*((j-1)**2);  dVetagl(Nz+1,j)=(j-1)**2;end do
! VANDERMONDE GAUSS dVG
do vandrow=1,Nz;  do vandcol=1,Nz;
Vetag(vandrow,vandcol)=cos(acos(etag(vandrow))*(vandcol-1));ARAVG(vandrow,vandcol)=sin(acos(etag(vandrow))*(vandcol-1));
end do ;end do;
 DIAG1VG=0.0;DIAG2VG=0.0;
do j=1,Nz;DIAG1VG(j,j)=1/SQRT(1-etag(j)**2);end do
do j=1,Nz;DIAG2VG(j,j)=j-1;  end do
 dVetaG=MATMUL(DIAG1VG,ARAVG);dVetaG=MATMUL(dVetaG,DIAG2VG)
!DIFFERENTIATION MATRIX  GAUSS-LOBATTO
 VGLforinv=Vetagl;CALL inverse(VGLforinv,invVGL,Nz+1);Detagl=MATMUL(dVetagl,invVGL)
D2etagl=MATMUL(Detagl,Detagl);
!DIFFERENTIATION MATRIX GAUSS
 VGforinv=vetag; CALL inverse(VGforinv,invVG,Nz);Detag=MATMUL(dVetaG,invVG)

! OPERATORs
 ZNx=0.0;do l = 1,Nz+1;ZNx(l, l) = 1; end do;
 ZNz=0.0;do l = 2,Nz;ZNz(l, l) = 1; end do;
 Igl=0.0;do l = 1,Nz+1;Igl(l, l) = 1; end do;
 Ig=0.0;do l = 1,Nz;Ig(l, l) = 1; end do;
 Igldt=0.0;do l = 1,Nz+1;Igldt(l, l) = (3/(2*dt)); end do;
 Iglvis=0.0;do l = 1,Nz+1;Iglvis(l, l) = vis; end do;

 VG_trunc=0;do l=1,Nz; VG_trunc(:,l)=Vetag(:,l); end do;
 div_x=MATMUL(VG_trunc,invVGL);div_x=MATMUL(div_x,Igl);div_x=MATMUL(div_x,ZNx)
 div_z=MATMUL(VG_trunc,invVGL);div_z=MATMUL(div_z,Detagl*eta_zgl);div_z=MATMUL(div_z,ZNz)
 grad_x=MATMUL(Vetagl(:,1:Nz),invVG);grad_x=MATMUL(grad_x,Ig);
 grad_z=MATMUL(Vetagl(:,1:Nz),invVG);grad_z=MATMUL(grad_z,Detag);grad_z=grad_z*eta_zg
 div_x_act_on_grad_x=-Ig;
 div_z_act_on_grad_z=MATMUL(div_z,grad_z)
call cpu_time(finish1)
!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! GENERAL FFT PLAN BACKWARD & FORWARD!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!
ALLOCATE(inf(1:Ny,1:Nx,1:Nz+1),outf(1:Ny,1:Nx,1:Nz+1))
  rank = 2;
  ppp(1) =Ny;  ppp(2) =Nx;
  howmany =Nz+1
  odist = ppp(1)*ppp(2);    idist =  ppp(1)*ppp(2);
  ostride = 1;  istride = 1;
  inembed(:) = ppp(:); onembed(:) = ppp(:);

call dfftw_plan_many_dft(planf,rank,ppp,howmany,inf,inembed,istride,idist,outf, onembed,ostride,odist, FFTW_FORWARD, FFTW_MEASURE);
call dfftw_plan_many_dft(planb,rank,ppp,howmany,outf,inembed,istride,idist,inf, onembed,ostride,odist, FFTW_BACKWARD, FFTW_MEASURE);

!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Constant Pressure Gradient Real&Fourier Space  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!
!f=-2/Re;
!call dfftw_execute_dft(planf,f,fh);
!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! INITIAL  CONDITIONS !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!
!call random_number(temp)
u=1;uold=1;v=0;vold=0;w=0;wold=0;
!u=temp;uold=temp;v=temp;vold=temp;w=temp;wold=temp;

do 100 tt=1,Nstep
!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! VELOCITY COMPONENTS  TRANSFROM TO FOURIER SPACE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!
call cpu_time(start2)
! U & UOLD
call dfftw_execute_dft_(planf,u,uh);call dfftw_execute_dft_(planf,uold,uoldh);
! V & Vold
call dfftw_execute_dft_(planf,v,vh);call dfftw_execute_dft_(planf,vold,voldh);
! w & Wold
call dfftw_execute_dft_(planf,w,wh);call dfftw_execute_dft_(planf,wold,woldh);
!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!PSEUDO SPECTRAL CONVECTIVE TERMS -NOT DEALIASED!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!
! X DERIVATIVES IN FOURIER SPACE du/dx&dv/dx&dw/dx at time t & t-1

do l=1,Nx;
dudxh(:,l,:)= uh(:,l,:)*kx(l)*i*xi_x;      dvdxh(:,l,:)= vh(:,l,:)*kx(l)*i*xi_x;      dwdxh(:,l,:)= wh(:,l,:)*kx(l)*i*xi_x;
dudxoldh(:,l,:)= uoldh(:,l,:)*kx(l)*i*xi_x;dvdxoldh(:,l,:)= voldh(:,l,:)*kx(l)*i*xi_x;dwdxoldh(:,l,:)= woldh(:,l,:)*kx(l)*i*xi_x;
end do

! Y DERIVATIVES IN FOURIER SPACE du/dz&dv/dz&dw/dz at time t & t-1
call cpu_time(startstart)

do l=1,Ny;
dudyh(l,:,:)= uh(l,:,:)*ky(l)*i*yi_y;      dvdyh(l,:,:)= vh(l,:,:)*ky(l)*i*yi_y;      dwdyh(l,:,:)= wh(l,:,:)*ky(l)*i*yi_y;
dudyoldh(l,:,:)= uoldh(l,:,:)*ky(l)*i*yi_y;dvdyoldh(l,:,:)= voldh(l,:,:)*ky(l)*i*yi_y;dwdyoldh(l,:,:)= woldh(l,:,:)*ky(l)*i*yi_y;
end do

call cpu_time(finishfinish)
! PSEUDO SPECTRAL BACKWARD TRANSFORM
call dfftw_execute_dft_(planb,dudxh,dudx);call dfftw_execute_dft_(planb,dudxoldh,dudxold);
dudx=dudx/(Nx*Ny);  dudxold=dudxold/(Nx*Ny);
call dfftw_execute_dft_(planb,dvdxh,dvdx);call dfftw_execute_dft_(planb,dvdxoldh,dvdxold);
dvdx=dvdx/(Nx*Ny);  dvdxold=dvdxold/(Nx*Ny);
call dfftw_execute_dft_(planb,dwdxh,dwdx);call dfftw_execute_dft_(planb,dwdxoldh,dwdxold);
dwdx=dwdx/(Nx*Ny);  dwdxold=dwdxold/(Nx*Ny);
call dfftw_execute_dft_(planb,dudyh,dudy);call dfftw_execute_dft_(planb,dudyoldh,dudyold);
dudy=dudy/(Nx*Ny);  dudyold=dudyold/(Nx*Ny);
call dfftw_execute_dft_(planb,dvdyh,dvdy);call dfftw_execute_dft_(planb,dvdyoldh,dvdyold);
dvdy=dvdy/(Nx*Ny); dvdyold=dvdyold/(Nx*Ny);
call dfftw_execute_dft_(planb,dwdyh,dwdy);call dfftw_execute_dft_(planb,dwdyoldh,dwdyold);
dwdy=dwdy/(Nx*Ny);  dwdyold=dwdyold/(Nx*Ny);
!!!!!NON LINEAR TERM MULTIPLICATION IN REAL SPACE
ududx=u*dudx;udvdx=u*dvdx;udwdx=u*dwdx;ududxold=uold*dudxold;udvdxold=uold*dvdxold;udwdxold=uold*dwdxold;
vdudy=v*dudy;vdvdy=v*dvdy;vdwdy=v*dwdy;vdudyold=vold*dudyold;vdvdyold=vold*dvdyold;vdwdyold=vold*dwdyold;

!! FORWARD TRANSFORM OF NON LINEAR TERMS
call dfftw_execute_dft_(planf,ududx,ududxh);call dfftw_execute_dft_(planf,ududxold,ududxoldh);
call dfftw_execute_dft_(planf,udvdx,udvdxh);call dfftw_execute_dft_(planf,udvdxold,udvdxoldh);
call dfftw_execute_dft_(planf,udwdx,udwdxh);call dfftw_execute_dft_(planf,udwdxold,udwdxoldh);

call dfftw_execute_dft_(planf,vdudy,vdudyh);call dfftw_execute_dft_(planf,vdudyold,vdudyoldh);
call dfftw_execute_dft_(planf,vdvdy,vdvdyh);call dfftw_execute_dft_(planf,vdvdyold,vdvdyoldh);
call dfftw_execute_dft_(planf,vdwdy,vdwdyh);call dfftw_execute_dft_(planf,vdwdyold,vdwdyoldh);
call cpu_time(finish2)

!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! NON PERIODIC BOUNDARIES IN Z DIRECTION  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!
!Z DERIVATIVES IN REAL SPACE FOR NON LINEAR TERMS
call cpu_time(start3)

do l=1,Nx;
do m=1,Ny;
dudz(m,l,:)=MATMUL(Detagl*eta_zgl,u(m,l,:));dvdz(m,l,:)=MATMUL(Detagl*eta_zgl,v(m,l,:)); dwdz(m,l,:)=MATMUL(Detagl*eta_zgl,w(m,l,:));
dudzold(m,l,:)=MATMUL(Detagl*eta_zgl,uold(m,l,:));
dvdzold(m,l,:)=MATMUL(Detagl*eta_zgl,vold(m,l,:)); dwdzold(m,l,:)=MATMUL(Detagl*eta_zgl,wold(m,l,:));
end do;
end do;

call cpu_time(finish3)
!  MULTIPLICATION IN REAL SPACE FOR NON LINEAR TERMS
wdudz=w*dudz;wdvdz=w*dvdz;wdwdz=w*dwdz;wdudzold=wold*dudzold;wdvdzold=wold*dvdzold;wdwdzold=wold*dwdzold;

! FORWARD FFT FOR NONLINEAR Z DERIVATIVE TERMS
call cpu_time(start4)
call dfftw_execute_dft_(planf,wdudz,wdudzh);call dfftw_execute_dft_(planf,wdudzold,wdudzoldh);
call dfftw_execute_dft_(planf,wdvdz,wdvdzh);call dfftw_execute_dft_(planf,wdvdzold,wdvdzoldh);
call dfftw_execute_dft_(planf,wdwdz,wdwdzh);call dfftw_execute_dft_(planf,wdwdzold,wdwdzoldh);
call cpu_time(finish4)
!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!
!!!!!!!!!!!!!!!!!!!!!! SOLVING THE LINEAR SYSTEMS FOR INT. VELOCITIES AND PRESSURE  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!---------------------------loop nr.23 for Y modes & loop nr.36 for X modes  --------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!

!call cpu_time(start5)
!!!!!!!!!!doprivate(A,convectiveu,rhsuint,convectivev,rhsvint,convectivew,rhswint,BB,ustar,vstar,wstar,RHS,LHS)
DO 23 m=1,Nx           !size(kz)
        DO 36 oo=1,Ny  !size(kx);
A=Igldt-D2etagl*(eta_zgl**2)*vis+((xi_x**2)*kx(m)**2)*Iglvis+((yi_y**2)*ky(m)**2)*Iglvis;
! Convective U
convectiveu=2*ududxh(oo,m,:)+2*vdudyh(oo,m,:)+2*wdudzh(oo,m,:)-ududxoldh(oo,m,:)-vdudyoldh(oo,m,:)-wdudzoldh(oo,m,:);
rhsuint=(2/dt)*uh(oo,m,:)-(1/(2*dt))*uoldh(oo,m,:)+convectiveu;!-fh(oo,m,:);
! Convective V
convectivev=2*vdvdyh(oo,m,:)+2*udvdxh(oo,m,:)+2*wdvdzh(oo,m,:)-udvdxoldh(oo,m,:)-vdvdyoldh(oo,m,:)-wdvdzoldh(oo,m,:);
rhsvint=(2/dt)*vh(oo,m,:)-(1/(2*dt))*voldh(oo,m,:)+convectivev;
! Convective W
convectivew=2*vdwdyh(oo,m,:)+2*udwdxh(oo,m,:)+2*wdwdzh(oo,m,:)-udwdxoldh(oo,m,:)-vdwdyoldh(oo,m,:)-wdwdzoldh(oo,m,:);
rhswint=(2/dt)*wh(oo,m,:)-(1/(2*dt))*woldh(oo,m,:)+convectivew;
! Assign B for simultaneous G.E.
BB(:,1)=rhsuint;BB(:,2)=rhsvint;BB(:,3)=rhswint;

! DO the G.E.
call CGESV(Nz+1, 3, A, Nz+1, pivot, BB, Nz+1, ok)
! Assign to inter. velocities
ustar=BB(:,1);vstar=BB(:,2);wstar=BB(:,3);
! Impose the boundary conditions.
ustar(1)=0;ustar(Nz+1)=0;vstar(1)=0;vstar(Nz+1)=0;wstar(1)=0;wstar(Nz+1)=0;
RHS = MATMUL(div_x,((kx(m)*i*xi_x)*ustar)) +  MATMUL(div_x,((ky(m)*i*yi_y)*vstar))+MATMUL(div_z,wstar);
LHS = (div_x_act_on_grad_x*(kx(m)**2*xi_x**2+ky(m)**2*yi_y**2) + div_z_act_on_grad_z );
LHS=dt*LHS;

call CGESV(Nz, 1, LHS, Nz, pivott, RHS, Nz, ok)
pnewh(oo,m,:)=RHS;
! Solve for velocities at new time step
unewh(oo,m,:) = ustar-MATMUL(dt*grad_x*(kx(m)*i*xi_x),pnewh(oo,m,:));
vnewh(oo,m,:) = vstar-MATMUL(dt*grad_x*(ky(m)*i*yi_y),pnewh(oo,m,:));
wnewh(oo,m,:) = wstar-MATMUL(dt*grad_z,pnewh(oo,m,:));

36 end do
23 end do

!call cpu_time(finish5)

!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!
!!!!!!!!!!!!!!!!!!!!!!  UPDATE THE VELOCITIES & IMPOSE BOUNDARY CONDITIONS !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!
! assign u to uold
call dfftw_execute_dft_(planb,unewh,u);u=REAL(u/(Nx*Ny));
! assign v to wold
call dfftw_execute_dft_(planb,vnewh,v);v=REAL(v/(Nx*Ny));
! assign w to wold
call dfftw_execute_dft_(planb,wnewh,w);w=REAL(w/(Nx*Ny));

!impose boundaries.
u(:,:,Nz+1)=1;u(:,:,1)=1;
v(:,:,Nz+1)=0;v(:,:,1)=0;
w(:,:,Nz+1)=0;w(:,:,1)=0;

! assign u to uold
call dfftw_execute_dft_(planb,uh,uold);uold=REAL(uold/(Nx*Ny));
! assign v to wold
call dfftw_execute_dft_(planb,vh,vold);vold=REAL(vold/(Nx*Ny));
! assign w to wold
call dfftw_execute_dft_(planb,wh,wold);wold=REAL(wold/(Nx*Ny));

100 end do

call cpu_time(finish)

write(*,*) finishfinish-startstart
!write(*,*) finish1-start1
!write(*,*) finish2-start2
!write(*,*) finish3-start3
!write(*,*) finish4-start4
!write(*,*) finish5-start5

!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!  SAVE DATA !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!------------------------------------------------------------------------------------------------------------------------------------------!
!------------------------------------------------------------------------------------------------------------------------------------------!

PRINT *, 'Nx = ', Nx, ', Ny = ', Ny,',Nz=',Nz,',timestep=',tt

name_config = './data/info.dat'
OPEN ( unit =11 , FILE = name_config  );REWIND (11);WRITE (11 ,*) Nx,Ny,Nz,Lx,Ly,Lz,tt,Re,dt;CLOSE (11)

name_config = './data/u';savearray = REAL(u);CALL savedata(Ny,Nx,Nz+1,1,name_config,savearray)
name_config = './data/v';savearray = REAL(v);CALL savedata(Ny,Nx,Nz+1,1,name_config,savearray)
name_config = './data/w';savearray = REAL(w);CALL savedata(Ny,Nx,Nz+1,1,name_config,savearray)

!do l=1,Nz+1
!write(*,*) 'u',l
!CALL DISP((u(:,:,l)))
!end do

end program halfmerged


use IOClass
use PCAClass

implicit none

type(IO_) :: f
type(PCA_) :: PCA

! Import data
call PCA%load(&
    filename="testdata.txt",&
    num_feature=3,&
    columns_are_feature_names=true)
! RUN PCA
call PCA%standarize()
call PCA%run()

! Export Data
call f%open("Feat_1_2.txt","w")
call f%write(PCA%DataFrame )
call f%close()
call f%splot()

call f%open("PC_1_2.txt","w")
call f%write(PCA%principalComponent() )
call f%close()
call f%plot()
end