      SUBROUTINE AB05PD( OVER, N1, M, P, N2, ALPHA, A1, LDA1, B1, LDB1,
     $                   C1, LDC1, D1, LDD1, A2, LDA2, B2, LDB2, C2,
     $                   LDC2, D2, LDD2, N, A, LDA, B, LDB, C, LDC, D,
     $                   LDD, INFO)
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the state-space model G = (A,B,C,D) corresponding to
C     the sum G = G1 + alpha*G2, where G1 = (A1,B1,C1,D1) and
C     G2 = (A2,B2,C2,D2).  G, G1, and G2 are the transfer-function
C     matrices of the corresponding state-space models.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     OVER    CHARACTER*1
C             Indicates whether the user wishes to overlap pairs of
C             arrays, as follows:
C             = 'N':  Do not overlap;
C             = 'O':  Overlap pairs of arrays: A1 and A, B1 and B,
C                     C1 and C, and D1 and D, i.e. the same name is
C                     effectively used for each pair (for all pairs)
C                     in the routine call.  In this case, setting
C                     LDA1 = LDA, LDB1 = LDB, LDC1 = LDC, and LDD1 = LDD
C                     will give maximum efficiency.
C
C     Input/Output Parameters
C
C     N1      (input) INTEGER
C             The number of state variables in the first system, i.e.
C             the order of the matrix A1, the number of rows of B1 and
C             the number of columns of C1.  N1 >= 0.
C
C     M       (input) INTEGER
C             The number of input variables of the two systems, i.e. the
C             number of columns of matrices B1, D1, B2 and D2.  M >= 0.
C
C     P       (input) INTEGER
C             The number of output variables of the two systems, i.e.
C             the number of rows of matrices C1, D1, C2 and D2.  P >= 0.
C
C     N2      (input) INTEGER
C             The number of state variables in the second system, i.e.
C             the order of the matrix A2, the number of rows of B2 and
C             the number of columns of C2.  N2 >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The coefficient multiplying G2.
C
C     A1      (input) DOUBLE PRECISION array, dimension (LDA1,N1)
C             The leading N1-by-N1 part of this array must contain the
C             state transition matrix A1 for the first system.
C
C     LDA1    INTEGER
C             The leading dimension of array A1.  LDA1 >= MAX(1,N1).
C
C     B1      (input) DOUBLE PRECISION array, dimension (LDB1,M)
C             The leading N1-by-M part of this array must contain the
C             input/state matrix B1 for the first system.
C
C     LDB1    INTEGER
C             The leading dimension of array B1.  LDB1 >= MAX(1,N1).
C
C     C1      (input) DOUBLE PRECISION array, dimension (LDC1,N1)
C             The leading P-by-N1 part of this array must contain the
C             state/output matrix C1 for the first system.
C
C     LDC1    INTEGER
C             The leading dimension of array C1.
C             LDC1 >= MAX(1,P) if N1 > 0.
C             LDC1 >= 1 if N1 = 0.
C
C     D1      (input) DOUBLE PRECISION array, dimension (LDD1,M)
C             The leading P-by-M part of this array must contain the
C             input/output matrix D1 for the first system.
C
C     LDD1    INTEGER
C             The leading dimension of array D1.  LDD1 >= MAX(1,P).
C
C     A2      (input) DOUBLE PRECISION array, dimension (LDA2,N2)
C             The leading N2-by-N2 part of this array must contain the
C             state transition matrix A2 for the second system.
C
C     LDA2    INTEGER
C             The leading dimension of array A2.  LDA2 >= MAX(1,N2).
C
C     B2      (input) DOUBLE PRECISION array, dimension (LDB2,M)
C             The leading N2-by-M part of this array must contain the
C             input/state matrix B2 for the second system.
C
C     LDB2    INTEGER
C             The leading dimension of array B2.  LDB2 >= MAX(1,N2).
C
C     C2      (input) DOUBLE PRECISION array, dimension (LDC2,N2)
C             The leading P-by-N2 part of this array must contain the
C             state/output matrix C2 for the second system.
C
C     LDC2    INTEGER
C             The leading dimension of array C2.
C             LDC2 >= MAX(1,P) if N2 > 0.
C             LDC2 >= 1 if N2 = 0.
C
C     D2      (input) DOUBLE PRECISION array, dimension (LDD2,M)
C             The leading P-by-M part of this array must contain the
C             input/output matrix D2 for the second system.
C
C     LDD2    INTEGER
C             The leading dimension of array D2.  LDD2 >= MAX(1,P).
C
C     N       (output) INTEGER
C             The number of state variables (N1 + N2) in the resulting
C             system, i.e. the order of the matrix A, the number of rows
C             of B and the number of columns of C.
C
C     A       (output) DOUBLE PRECISION array, dimension (LDA,N1+N2)
C             The leading N-by-N part of this array contains the state
C             transition matrix A for the resulting system.
C             The array A can overlap A1 if OVER = 'O'.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N1+N2).
C
C     B       (output) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array contains the
C             input/state matrix B for the resulting system.
C             The array B can overlap B1 if OVER = 'O'.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N1+N2).
C
C     C       (output) DOUBLE PRECISION array, dimension (LDC,N1+N2)
C             The leading P-by-N part of this array contains the
C             state/output matrix C for the resulting system.
C             The array C can overlap C1 if OVER = 'O'.
C
C     LDC     INTEGER
C             The leading dimension of array C.
C             LDC >= MAX(1,P) if N1+N2 > 0.
C             LDC >= 1 if N1+N2 = 0.
C
C     D       (output) DOUBLE PRECISION array, dimension (LDD,M)
C             The leading P-by-M part of this array contains the
C             input/output matrix D for the resulting system.
C             The array D can overlap D1 if OVER = 'O'.
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,P).
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     METHOD
C
C     The matrices of the resulting systems are determined as:
C
C           ( A1   0  )             ( B1 )
C       A = (         ) ,       B = (    ) ,
C           ( 0    A2 )             ( B2 )
C
C       C = ( C1  alpha*C2 ) ,  D = D1 + alpha*D2 .
C
C     REFERENCES
C
C     None
C
C     NUMERICAL ASPECTS
C
C     None
C
C     CONTRIBUTORS
C
C     A. Varga, German Aerospace Research Establishment,
C     Oberpfaffenhofen, Germany, and V. Sima, Katholieke Univ. Leuven,
C     Belgium, Nov. 1996.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, July 2003,
C     Feb. 2004.
C
C     KEYWORDS
C
C     Multivariable system, state-space model, state-space
C     representation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO=0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         OVER
      INTEGER           INFO, LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC,
     $                  LDC1, LDC2, LDD, LDD1, LDD2, M, N, N1, N2, P
      DOUBLE PRECISION  ALPHA
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), A1(LDA1,*), A2(LDA2,*), B(LDB,*),
     $                  B1(LDB1,*), B2(LDB2,*), C(LDC,*), C1(LDC1,*),
     $                  C2(LDC2,*), D(LDD,*), D1(LDD1,*), D2(LDD2,*)
C     .. Local Scalars ..
      LOGICAL           LOVER
      INTEGER           I, J, N1P1
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DLACPY, DLASCL, DLASET, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C     .. Executable Statements ..
C
      LOVER = LSAME( OVER, 'O' )
      N = N1 + N2
      INFO = 0
C
C     Test the input scalar arguments.
C
      IF( .NOT.LOVER .AND. .NOT.LSAME( OVER, 'N' ) ) THEN
         INFO = -1
      ELSE IF( N1.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( N2.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA1.LT.MAX( 1, N1 ) ) THEN
         INFO = -8
      ELSE IF( LDB1.LT.MAX( 1, N1 ) ) THEN
         INFO = -10
      ELSE IF( ( N1.GT.0 .AND. LDC1.LT.MAX( 1, P ) ) .OR.
     $         ( N1.EQ.0 .AND. LDC1.LT.1 ) ) THEN
         INFO = -12
      ELSE IF( LDD1.LT.MAX( 1, P ) ) THEN
         INFO = -14
      ELSE IF( LDA2.LT.MAX( 1, N2 ) ) THEN
         INFO = -16
      ELSE IF( LDB2.LT.MAX( 1, N2 ) ) THEN
         INFO = -18
      ELSE IF( ( N2.GT.0 .AND. LDC2.LT.MAX( 1, P ) ) .OR.
     $         ( N2.EQ.0 .AND. LDC2.LT.1 ) ) THEN
         INFO = -20
      ELSE IF( LDD2.LT.MAX( 1, P ) ) THEN
         INFO = -22
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -25
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -27
      ELSE IF( ( N.GT.0 .AND. LDC.LT.MAX( 1, P ) ) .OR.
     $         ( N.EQ.0 .AND. LDC.LT.1 ) ) THEN
         INFO = -29
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -31
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB05PD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MAX( N, MIN( M, P ) ).EQ.0 )
     $   RETURN
C
      N1P1 = N1 + 1
C
C                       ( A1   0  )
C     Construct     A = (         ) .
C                       ( 0    A2 )
C
      IF ( LOVER .AND. LDA1.LE.LDA ) THEN
         IF ( LDA1.LT.LDA ) THEN
C
            DO 20 J = N1, 1, -1
               DO 10 I = N1, 1, -1
                  A(I,J) = A1(I,J)
   10          CONTINUE
   20       CONTINUE
C
         END IF
      ELSE
         CALL DLACPY( 'F', N1, N1, A1, LDA1, A, LDA )
      END IF
C
      IF ( N2.GT.0 ) THEN
         CALL DLASET( 'F', N1, N2, ZERO, ZERO, A(1,N1P1), LDA )
         CALL DLASET( 'F', N2, N1, ZERO, ZERO, A(N1P1,1), LDA )
         CALL DLACPY( 'F', N2, N2, A2, LDA2, A(N1P1,N1P1), LDA )
      END IF
C
C                        ( B1 )
C     Construct      B = (    ) .
C                        ( B2 )
C
      IF ( LOVER .AND. LDB1.LE.LDB ) THEN
         IF ( LDB1.LT.LDB ) THEN
C
            DO 40 J = M, 1, -1
               DO 30 I = N1, 1, -1
                  B(I,J) = B1(I,J)
   30          CONTINUE
   40       CONTINUE
C
         END IF
      ELSE
         CALL DLACPY( 'F', N1, M, B1, LDB1, B, LDB )
      END IF
C
      IF ( N2.GT.0 )
     $   CALL DLACPY( 'F', N2, M, B2, LDB2, B(N1P1,1), LDB )
C
C     Construct      C = ( C1 alpha*C2 ) .
C
      IF ( LOVER .AND. LDC1.LE.LDC ) THEN
         IF ( LDC1.LT.LDC ) THEN
C
            DO 60 J = N1, 1, -1
               DO 50 I = P, 1, -1
                  C(I,J) = C1(I,J)
   50          CONTINUE
   60       CONTINUE
C
         END IF
      ELSE
         CALL DLACPY( 'F', P, N1, C1, LDC1, C, LDC )
      END IF
C
      IF ( N2.GT.0 ) THEN
         CALL DLACPY( 'F', P, N2, C2, LDC2, C(1,N1P1), LDC )
         IF ( ALPHA.NE.ONE )
     $      CALL DLASCL( 'G', 0, 0, ONE, ALPHA, P, N2, C(1,N1P1), LDC,
     $                   INFO )
      END IF
C
C     Construct       D = D1 + alpha*D2 .
C
      IF ( LOVER .AND. LDD1.LE.LDD ) THEN
         IF ( LDD1.LT.LDD ) THEN
C
            DO 80 J = M, 1, -1
               DO 70 I = P, 1, -1
                  D(I,J) = D1(I,J)
   70          CONTINUE
   80       CONTINUE
C
         END IF
      ELSE
         CALL DLACPY( 'F', P, M, D1, LDD1, D, LDD )
      END IF
C
      DO 90 J = 1, M
         CALL DAXPY( P, ALPHA, D2(1,J), 1, D(1,J), 1 )
   90 CONTINUE
C
      RETURN
C *** Last line of AB05PD ***
      END


      SUBROUTINE POWP(NNNN,XXXX,YYYY)
C
C THIS SUBROUTINE TAKES A NON-NEGATIVE POWER OF A COMPLEX NUMBER:
C YYYY = XXXX**NNNN USING DE MOIVRE'S FORMULA:
C
C     YYYY = R**NNNN * (COS(NNNN*THETA),SIN(NNNN*THETA)),
C
C WHERE R=DNRM2(2,XXXX,1) AND THETA=ATAN2(XXXX(2),XXXX(1)).
C
C NOTE: POWP SETS 0**0 EQUAL TO 1.
C
C ON INPUT:
C
C NNNN  IS A NON-NEGATIVE INTEGER.
C
C XXXX  IS AN ARRAY OF LENGTH TWO REPRESENTING A COMPLEX
C       NUMBER, WHERE XXXX(1) = REAL PART OF XXXX AND XXXX(2) =
C       IMAGINARY PART OF XXXX.
C
C ON OUTPUT:
C
C YYYY  IS AN ARRAY OF LENGTH TWO REPRESENTING THE RESULT OF
C       THE POWER, YYYY = XXXX**NNNN, WHERE YYYY(1) =
C       REAL PART OF YYYY AND YYYY(2) = IMAGINARY PART OF YYYY.
C
C SUBROUTINES: COS, SIN, ATAN2, DNRM2
C
C DECLARATION OF INPUT
      INTEGER NNNN
      DOUBLE PRECISION XXXX
      DIMENSION XXXX(2)
C
C DECLARATION OF OUTPUT
      DOUBLE PRECISION YYYY
      DIMENSION YYYY(2)
C
C DECLARATION OF VARIABLES
      DOUBLE PRECISION R,RR,T,TT
C
C DECLARATION OF FUNCTIONS
      DOUBLE PRECISION  DNRM2
C
      IF (NNNN .EQ. 0) THEN
          YYYY(1)=1.
          YYYY(2)=0.
          RETURN
      ENDIF
      IF (NNNN .EQ. 1) THEN
          YYYY(1)=XXXX(1)
          YYYY(2)=XXXX(2)
          RETURN
      ENDIF
      R = DNRM2(2,XXXX,1)
      IF (R .EQ. 0.0) THEN
          YYYY(1)=0.0
          YYYY(2)=0.0
          RETURN
      END IF
      RR= R**NNNN
      T = ATAN2(XXXX(2),XXXX(1))
      TT= NNNN*T
      YYYY(1) = RR*COS(TT)
      YYYY(2) = RR*SIN(TT)
      RETURN
      END


*> \brief \b SQRT11
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       REAL             FUNCTION SQRT11( M, K, A, LDA, TAU, WORK, LWORK )
*
*       .. Scalar Arguments ..
*       INTEGER            K, LDA, LWORK, M
*       ..
*       .. Array Arguments ..
*       REAL               A( LDA, * ), TAU( * ), WORK( LWORK )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SQRT11 computes the test ratio
*>
*>       || Q'*Q - I || / (eps * m)
*>
*> where the orthogonal matrix Q is represented as a product of
*> elementary transformations.  Each transformation has the form
*>
*>    H(k) = I - tau(k) v(k) v(k)'
*>
*> where tau(k) is stored in TAU(k) and v(k) is an m-vector of the form
*> [ 0 ... 0 1 x(k) ]', where x(k) is a vector of length m-k stored
*> in A(k+1:m,k).
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*>          K is INTEGER
*>          The number of columns of A whose subdiagonal entries
*>          contain information about orthogonal transformations.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is REAL array, dimension (LDA,K)
*>          The (possibly partial) output of a QR reduction routine.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*>          TAU is REAL array, dimension (K)
*>          The scaling factors tau for the elementary transformations as
*>          computed by the QR factorization routine.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The length of the array WORK.  LWORK >= M*M + M.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_lin
*
*  =====================================================================
      REAL             FUNCTION SQRT11( M, K, A, LDA, TAU, WORK, LWORK )
*
*  -- LAPACK test routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            K, LDA, LWORK, M
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), TAU( * ), WORK( LWORK )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
*     ..
*     .. Local Scalars ..
      INTEGER            INFO, J
*     ..
*     .. External Functions ..
      REAL               SLAMCH, SLANGE
      EXTERNAL           SLAMCH, SLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLASET, SORM2R, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          REAL
*     ..
*     .. Local Arrays ..
      REAL               RDUMMY( 1 )
*     ..
*     .. Executable Statements ..
*
      SQRT11 = ZERO
*
*     Test for sufficient workspace
*
      IF( LWORK.LT.M*M+M ) THEN
         CALL XERBLA( 'SQRT11', 7 )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.LE.0 )
     $   RETURN
*
      CALL SLASET( 'Full', M, M, ZERO, ONE, WORK, M )
*
*     Form Q
*
      CALL SORM2R( 'Left', 'No transpose', M, M, K, A, LDA, TAU, WORK,
     $             M, WORK( M*M+1 ), INFO )
*
*     Form Q'*Q
*
      CALL SORM2R( 'Left', 'Transpose', M, M, K, A, LDA, TAU, WORK, M,
     $             WORK( M*M+1 ), INFO )
*
      DO 10 J = 1, M
         WORK( ( J-1 )*M+J ) = WORK( ( J-1 )*M+J ) - ONE
   10 CONTINUE
*
      SQRT11 = SLANGE( 'One-norm', M, M, WORK, M, RDUMMY ) /
     $         ( REAL( M )*SLAMCH( 'Epsilon' ) )
*
      RETURN
*
*     End of SQRT11
*
      END


!  *******************************************************************
!  *                                                                 *
!  *                     Function dlsfr3                             *
!  *                                                                 *
!  *******************************************************************
!  Double Precision Version 1.31
!  Written by Gordon A. Fenton, TUNS, Mar. 15, 1995
!  Latest Update: May 9, 2001
!
!  PURPOSE  returns the covariance between two points in a separable 3-D
!           fractional Gaussian noise field
!
!  Returns the covariance between two points in the field separated by the
!  lag vector {X,Y,Z}. The covariance function is a separable fractional
!  Gaussian noise, given by
!
!         B(X,Y,Z) = var*r(X)*r(Y)*r(Z)
!
!  for two points separated by distance {X,Y,Z}, where r(X), r(Y), and r(Z)
!  are the correlation functions given by
!
!               1               2H       2H           2H
!     r(X) = -------- [ |X + pb|  -  2|X|  +  |X - pb|  ]		(1)
!                 2H
!             2*pb
!
!
!               1               2G       2G           2G
!     r(Y) = -------- [ |Y + pb|  -  2|Y|  +  |Y - pb|  ]		(2)
!                 2G
!             2*pb
!
!
!               1               2F       2F           2F
!     r(Z) = -------- [ |Z + pb|  -  2|Z|  +  |Z - pb|  ]		(2)
!                 2F
!             2*pb
!
!  and where `pb' is the length over which the fractional Brownian motion is
!  averaged in order to make this, the derivative process, exist. Normally
!  `pb' is selected to be quite small (of the order of the size of the
!  discretization interval). The parameters `F', `G', and `H' are the
!  self-similar parameters, or Hurst exponents, (0.5 < F,G,H < 1) with
!  F = G = H = 1 giving a total correlated field and F = G = H = 0.5 giving
!  a white noise field (for sufficiently small pb). Finally var is the
!  point variance of the process.
!
!  The parameters var, pb, H, G, and F are brought in via the common
!  block /dparam/.
!
!  If var < 0, then this function computes the variance of a local average
!  of the random field, |var|*V(X,Y,Z), averaged over a domain having side
!  dimensions {X,Y,Z}. For a separable covariance function, the variance
!  function is also separable,
!
!     V(X,Y,Z) = V(X)*V(Y)*V(Z)
!
!  where (X,Y,Z) gives the dimensions of the averaging region. The 1-D
!  variance function corresponding to Eq. (1) is given by
!
!                        r        r      r            r
!                |X + pb| - 2( |X| + |pb| ) + |X - pb|
!       V(X) = -----------------------------------------		(3)
!                      2                  2H
!                     X * (2H+1)*(2H+2)*pb
!
!  where r = (2*H+2). Notice that as X goes to zero the above becomes 0/0, but
!  its limiting value is 1.0. A similar relationship holds for the variance
!  function corresponding to (2).
!
!  Parameters to this process are brought in through the common block
!  /dparam/ and are described as follows;
!
!     var	the point variance of the fGn process.
!
!      pb	the averaging length discussed above. This is assumed common
!		for all three directions.
!
!       H	the Hurst exponent governing the process in the X direction.
!		In this implementation, 0.5 < H < 1; values of H near 1 yield
!		a correlation structure which remains very high (and thus a
!		covariance matrix which may be nearly singular). Values of H
!		near 0.5 yield a band- limited white noise process.
!
!       G	the Hurst exponent governing the process in the Y direction.
!		In this implementation, 0.5 < G < 1; values of G near 1 yield
!		a correlation structure which remains very high (and thus a
!		covariance matrix which may be nearly singular). Values of G
!		near 0.5 yield a band- limited white noise process.
!
!       F	the Hurst exponent governing the process in the Z direction.
!		In this implementation, 0.5 < F < 1; values of F near 1 yield
!		a correlation structure which remains very high (and thus a
!		covariance matrix which may be nearly singular). Values of F
!		near 0.5 yield a band- limited white noise process.
!
!  Arguments to this function are just the X, Y, and Z elements of the
!  lag vector between points in the field for which the covariance is
!  desired (or the dimensions of the physical averaging region, if var < 0).
!
!  REVISION HISTORY:
!  1.1	added lvarfn flag to end of /dparam/ common block. Set it to
!	true if the variance function is to be returned. Otherwise this
!	function returns the covariance. (May 1/00)
!  1.2	eliminated lvarfn -- now return covariances only if var < 0 (Apr 9/01)
!  1.3	reversed default - now return covariances if var > 0. (Apr 11/01)
!  1.31	revised above documentation to reflect revision 1.3 (May 9/01)
!----------------------------------------------------------------------
      real*8 function dlsfr3( X, Y, Z )
      implicit real*8 (a-h,o-z)
      common/dparam/ var, pb, H, G, F
      data zero/0.d0/, one/1.d0/, two/2.d0/
      abs(q)  = dabs(q)

      if( var .lt. zero ) then			! return variance function
!							X-direction var func
         if( X .eq. zero ) then
            v1 = one
         else
            e0 = two*H
            e1 = e0 + one
            e2 = e0 + two
            t1 = abs(X+pb)**e2-two*(abs(X)**e2+pb**e2)+abs(X-pb)**e2
            v1 = t1/(X*X*e1*e2*pb**e0)
         endif
!							Y-direction var func
         if( Y .eq. zero ) then
            v2 = one
         else
            e0 = two*G
            e1 = e0 + one
            e2 = e0 + two
            t1 = abs(Y+pb)**e2-two*(abs(Y)**e2+pb**e2)+abs(Y-pb)**e2
            v2 = t1/(Y*Y*e1*e2*pb**e0)
         endif
!						Z-direction var func
         if( Z .eq. zero ) then
            v3 = one
         else
            e0 = two*F
            e1 = e0 + one
            e2 = e0 + two
            t1 = abs(Z+pb)**e2-two*(abs(Z)**e2+pb**e2)+abs(Z-pb)**e2
            v3 = t1/(Z*Z*e1*e2*pb**e0)
         endif
!							final variance function
         dlsfr3 = -var*v1*v2*v3
      else					! return covariance
         eH = two*H
         eG = two*G
         eF = two*F
         pH = two*(pb**eH)
         pG = two*(pb**eG)
         pF = two*(pb**eF)
         tH = abs(X+pb)**eH-two*(abs(X)**eH)+abs(X-pb)**eH
         tG = abs(Y+pb)**eG-two*(abs(Y)**eG)+abs(Y-pb)**eG
         tF = abs(Y+pb)**eF-two*(abs(Y)**eF)+abs(Y-pb)**eF
         dlsfr2 = var*tH*tG*tF/(pH*pG*pF)
      endif

      return
      end


*  Copyright (C) 2009 Intel Corporation. All Rights Reserved.
*  The information and material ("Material") provided below is owned by Intel
*  Corporation or its suppliers or licensors, and title to such Material remains
*  with Intel Corporation or its suppliers or licensors. The Material contains
*  proprietary information of Intel or its suppliers and licensors. The Material
*  is protected by worldwide copyright laws and treaty provisions. No part of
*  the Material may be copied, reproduced, published, uploaded, posted,
*  transmitted, or distributed in any way without Intel's prior express written
*  permission. No license under any patent, copyright or other intellectual
*  property rights in the Material is granted to or conferred upon you, either
*  expressly, by implication, inducement, estoppel or otherwise. Any license
*  under such intellectual property rights must be express and approved by Intel
*  in writing.
*  =============================================================================
*
*  CGESV Example.
*  ==============
*
*  The program computes the solution to the system of linear
*  equations with a square matrix A and multiple
*  right-hand sides B, where A is the coefficient matrix:
*
*  (  1.23, -5.50) (  7.91, -5.38) ( -9.80, -4.86) ( -7.32,  7.57)
*  ( -2.14, -1.12) ( -9.92, -0.79) ( -9.18, -1.12) (  1.37,  0.43)
*  ( -4.30, -7.10) ( -6.47,  2.52) ( -6.51, -2.67) ( -5.86,  7.38)
*  (  1.27,  7.29) (  8.90,  6.92) ( -8.82,  1.25) (  5.41,  5.37)
*
*  and B is the right-hand side matrix:
*
*  (  8.33, -7.32) ( -6.11, -3.81)
*  ( -6.18, -4.80) (  0.14, -7.71)
*  ( -5.71, -2.80) (  1.41,  3.40)
*  ( -1.60,  3.08) (  8.54, -4.05)
*
*  Description.
*  ============
*
*  The routine solves for X the system of linear equations A*X = B,
*  where A is an n-by-n matrix, the columns of matrix B are individual
*  right-hand sides, and the columns of X are the corresponding
*  solutions.
*
*  The LU decomposition with partial pivoting and row interchanges is
*  used to factor A as A = P*L*U, where P is a permutation matrix, L
*  is unit lower triangular, and U is upper triangular. The factored
*  form of A is then used to solve the system of equations A*X = B.
*
*  Example Program Results.
*  ========================
*
* CGESV Example Program Results
*
* Solution
* ( -1.09, -0.18) (  1.28,  1.21)
* (  0.97,  0.52) ( -0.22, -0.97)
* ( -0.20,  0.19) (  0.53,  1.36)
* ( -0.59,  0.92) (  2.22, -1.00)
*
* Details of LU factorization
* ( -4.30, -7.10) ( -6.47,  2.52) ( -6.51, -2.67) ( -5.86,  7.38)
* (  0.49,  0.47) ( 12.26, -3.57) ( -7.87, -0.49) ( -0.98,  6.71)
* (  0.25, -0.15) ( -0.60, -0.37) (-11.70, -4.64) ( -1.35,  1.38)
* ( -0.83, -0.32) (  0.05,  0.58) (  0.93, -0.50) (  2.66,  7.86)
*
* Pivot indices
*      3      3      3      4
*  =============================================================================
*
*     .. Parameters ..
      INTEGER          N, NRHS
      PARAMETER        ( N = 4, NRHS = 2 )
      INTEGER          LDA, LDB
      PARAMETER        ( LDA = N, LDB = N )
*
*     .. Local Scalars ..
      INTEGER          INFO
*
*     .. Local Arrays ..
      INTEGER          IPIV( N )
      COMPLEX          A( LDA, N ), B( LDB, NRHS )
      DATA             A/
     $ ( 1.23,-5.50),(-2.14,-1.12),(-4.30,-7.10),( 1.27, 7.29),
     $ ( 7.91,-5.38),(-9.92,-0.79),(-6.47, 2.52),( 8.90, 6.92),
     $ (-9.80,-4.86),(-9.18,-1.12),(-6.51,-2.67),(-8.82, 1.25),
     $ (-7.32, 7.57),( 1.37, 0.43),(-5.86, 7.38),( 5.41, 5.37)
     $                  /
      DATA             B/
     $ ( 8.33,-7.32),(-6.18,-4.80),(-5.71,-2.80),(-1.60, 3.08),
     $ (-6.11,-3.81),( 0.14,-7.71),( 1.41, 3.40),( 8.54,-4.05)
     $                  /
*
*     .. External Subroutines ..
      EXTERNAL         CGESV
      EXTERNAL         PRINT_MATRIX, PRINT_INT_VECTOR
*
*     .. Executable Statements ..
      WRITE(*,*)'CGESV Example Program Results'
*
*     Solve the equations A*X = B.
*
      CALL CGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
*     Check for the exact singularity.
*
      IF( INFO.GT.0 ) THEN
         WRITE(*,*)'The diagonal element of the triangular factor of A,'
         WRITE(*,*)'U(',INFO,',',INFO,') is zero, so that'
         WRITE(*,*)'A is singular; the solution could not be computed.'
         STOP
      END IF
*
*     Print solution.
*
      CALL PRINT_MATRIX( 'Solution', N, NRHS, B, LDB )
*
*     Print details of LU factorization.
*
      CALL PRINT_MATRIX( 'Details of LU factorization', N, N, A, LDA )
*
*     Print pivot indices.
*
      CALL PRINT_INT_VECTOR( 'Pivot indices', N, IPIV )
      STOP
      END
*
*     End of CGESV Example.
*
*  =============================================================================
*
*     Auxiliary routine: printing a matrix.
*
      SUBROUTINE PRINT_MATRIX( DESC, M, N, A, LDA )
      CHARACTER*(*)    DESC
      INTEGER          M, N, LDA
      COMPLEX          A( LDA, * )
*
      INTEGER          I, J
*
      WRITE(*,*)
      WRITE(*,*) DESC
      DO I = 1, M
         WRITE(*,9998) ( A( I, J ), J = 1, N )
      END DO
*
 9998 FORMAT( 11(:,1X,'(',F6.2,',',F6.2,')') )
      RETURN
      END
*
*     Auxiliary routine: printing a vector of integers.
*
      SUBROUTINE PRINT_INT_VECTOR( DESC, N, A )
      CHARACTER*(*)    DESC
      INTEGER          N
      INTEGER          A( N )
*
      INTEGER          I
*
      WRITE(*,*)
      WRITE(*,*) DESC
      WRITE(*,9999) ( A( I ), I = 1, N )
*
 9999 FORMAT( 11(:,1X,I6) )
      RETURN
      END


* wsc@research.bell-labs.com Mon Dec 30 16:55 EST 1985
* W. S. Cleveland
* Bell Laboratories
* Murray Hill NJ 07974
*
* outline of this file:
*    lines 1-72   introduction
*        73-177   documentation for lowess
*       178-238   ratfor version of lowess
*       239-301   documentation for lowest
*       302-350   ratfor version of lowest
*       351-end   test driver and fortran version of lowess and lowest
*
*   a multivariate version is available by "send dloess from a"
*
*              COMPUTER PROGRAMS FOR LOCALLY WEIGHTED REGRESSION
*
*             This package consists  of  two  FORTRAN  programs  for
*        smoothing    scatterplots   by   robust   locally   weighted
*        regression, or lowess.   The  principal  routine  is  LOWESS
*        which   computes   the  smoothed  values  using  the  method
*        described in The Elements of Graphing Data, by William S.
*        Cleveland    (Wadsworth,    555 Morego   Street,   Monterey,
*        California 93940).
*
*             LOWESS calls a support routine, LOWEST, the code for
*        which is included. LOWESS also calls a routine  SORT,  which
*        the user must provide.
*
*             To reduce the computations, LOWESS  requires  that  the
*        arrays  X  and  Y,  which  are  the  horizontal and vertical
*        coordinates, respectively, of the scatterplot, be such  that
*        X  is  sorted  from  smallest  to  largest.   The  user must
*        therefore use another sort routine which will sort X  and  Y
*        according  to X.
*             To summarize the scatterplot, YS,  the  fitted  values,
*        should  be  plotted  against X.   No  graphics  routines are
*        available in the package and must be supplied by the user.
*
*             The FORTRAN code for the routines LOWESS and LOWEST has
*        been   generated   from   higher   level   RATFOR   programs
*        (B. W. Kernighan, ``RATFOR:  A Preprocessor for  a  Rational
*        Fortran,''  Software Practice and Experience, Vol. 5 (1975),
*        which are also included.
*
*             The following are data and output from LOWESS that  can
*        be  used  to check your implementation of the routines.  The
*        notation (10)v means 10 values of v.
*
*
*
*
*        X values:
*          1  2  3  4  5  (10)6  8  10  12  14  50
*
*        Y values:
*           18  2  15  6  10  4  16  11  7  3  14  17  20  12  9  13  1  8  5  19
*
*
*        YS values with F = .25, NSTEPS = 0, DELTA = 0.0
*         13.659  11.145  8.701  9.722  10.000  (10)11.300  13.000  6.440  5.596
*           5.456  18.998
*
*        YS values with F = .25, NSTEPS = 0 ,  DELTA = 3.0
*          13.659  12.347  11.034  9.722  10.511  (10)11.300  13.000  6.440  5.596
*            5.456  18.998
*
*        YS values with F = .25, NSTEPS = 2, DELTA = 0.0
*          14.811  12.115  8.984  9.676  10.000  (10)11.346  13.000  6.734  5.744
*            5.415  18.998
*
*
*
*
*                                   LOWESS
*
*
*
*        Calling sequence
*
*        CALL LOWESS(X,Y,N,F,NSTEPS,DELTA,YS,RW,RES)
*
*        Purpose
*
*        LOWESS computes the smooth of a scatterplot of Y  against  X
*        using  robust  locally  weighted regression.  Fitted values,
*        YS, are computed at each of the  values  of  the  horizontal
*        axis in X.
*
*        Argument description
*
*              X = Input; abscissas of the points on the
*                  scatterplot; the values in X must be ordered
*                  from smallest to largest.
*              Y = Input; ordinates of the points on the
*                  scatterplot.
*              N = Input; dimension of X,Y,YS,RW, and RES.
*              F = Input; specifies the amount of smoothing; F is
*                  the fraction of points used to compute each
*                  fitted value; as F increases the smoothed values
*                  become smoother; choosing F in the range .2 to
*                  .8 usually results in a good fit; if you have no
*                  idea which value to use, try F = .5.
*         NSTEPS = Input; the number of iterations in the robust
*                  fit; if NSTEPS = 0, the nonrobust fit is
*                  returned; setting NSTEPS equal to 2 should serve
*                  most purposes.
*          DELTA = input; nonnegative parameter which may be used
*                  to save computations; if N is less than 100, set
*                  DELTA equal to 0.0; if N is greater than 100 you
*                  should find out how DELTA works by reading the
*                  additional instructions section.
*             YS = Output; fitted values; YS(I) is the fitted value
*                  at X(I); to summarize the scatterplot, YS(I)
*                  should be plotted against X(I).
*             RW = Output; robustness weights; RW(I) is the weight
*                  given to the point (X(I),Y(I)); if NSTEPS = 0,
*                  RW is not used.
*            RES = Output; residuals; RES(I) = Y(I)-YS(I).
*
*
*        Other programs called
*
*               LOWEST
*               SSORT
*
*        Additional instructions
*
*        DELTA can be used to save computations.   Very  roughly  the
*        algorithm  is  this:   on the initial fit and on each of the
*        NSTEPS iterations locally weighted regression fitted  values
*        are computed at points in X which are spaced, roughly, DELTA
*        apart; then the fitted values at the  remaining  points  are
*        computed  using  linear  interpolation.   The  first locally
*        weighted regression (l.w.r.) computation is carried  out  at
*        X(1)  and  the  last  is  carried  out at X(N).  Suppose the
*        l.w.r. computation is carried out at  X(I).   If  X(I+1)  is
*        greater  than  or  equal  to  X(I)+DELTA,  the  next  l.w.r.
*        computation is carried out at X(I+1).   If  X(I+1)  is  less
*        than X(I)+DELTA, the next l.w.r.  computation is carried out
*        at the largest X(J) which is greater than or equal  to  X(I)
*        but  is not greater than X(I)+DELTA.  Then the fitted values
*        for X(K) between X(I)  and  X(J),  if  there  are  any,  are
*        computed  by  linear  interpolation  of the fitted values at
*        X(I) and X(J).  If N is less than 100 then DELTA can be  set
*        to  0.0  since  the  computation time will not be too great.
*        For larger N it is typically not necessary to carry out  the
*        l.w.r.  computation for all points, so that much computation
*        time can be saved by taking DELTA to be  greater  than  0.0.
*        If  DELTA =  Range  (X)/k  then,  if  the  values  in X were
*        uniformly  scattered  over  the  range,  the   full   l.w.r.
*        computation  would be carried out at approximately k points.
*        Taking k to be 50 often works well.
*
*        Method
*
*        The fitted values are computed by using the nearest neighbor
*        routine  and  robust locally weighted regression of degree 1
*        with the tricube weight function.  A few additional features
*        have  been  added.  Suppose r is FN truncated to an integer.
*        Let  h  be  the  distance  to  the  r-th  nearest   neighbor
*        from X(I).   All  points within h of X(I) are used.  Thus if
*        the r-th nearest neighbor is exactly the  same  distance  as
*        other  points,  more  than r points can possibly be used for
*        the smooth at  X(I).   There  are  two  cases  where  robust
*        locally  weighted regression of degree 0 is actually used at
*        X(I).  One case occurs when  h  is  0.0.   The  second  case
*        occurs  when  the  weighted  standard error of the X(I) with
*        respect to the weights w(j) is  less  than  .001  times  the
*        range  of the X(I), where w(j) is the weight assigned to the
*        j-th point of X (the tricube  weight  times  the  robustness
*        weight)  divided by the sum of all of the weights.  Finally,
*        if the w(j) are all zero for the smooth at X(I), the  fitted
*        value is taken to be Y(I).
*
*
*
*
*  subroutine lowess(x,y,n,f,nsteps,delta,ys,rw,res)
*  real x(n),y(n),ys(n),rw(n),res(n)
*  logical ok
*  if (n<2){ ys(1) = y(1); return }
*  ns = max0(min0(ifix(f*float(n)),n),2)  # at least two, at most n points
*  for(iter=1; iter<=nsteps+1; iter=iter+1){      # robustness iterations
*         nleft = 1; nright = ns
*         last = 0        # index of prev estimated point
*         i = 1   # index of current point
*         repeat{
*                 while(nright<n){
*  # move nleft, nright to right if radius decreases
*                         d1 = x(i)-x(nleft)
*                         d2 = x(nright+1)-x(i)
*  # if d1<=d2 with x(nright+1)==x(nright), lowest fixes
*                         if (d1<=d2) break
*  # radius will not decrease by move right
*                         nleft = nleft+1
*                         nright = nright+1
*                         }
*                 call lowest(x,y,n,x(i),ys(i),nleft,nright,res,iter>1,rw,ok)
*  # fitted value at x(i)
*                 if (!ok) ys(i) = y(i)
*  # all weights zero - copy over value (all rw==0)
*                 if (last<i-1) { # skipped points -- interpolate
*                         denom = x(i)-x(last)    # non-zero - proof?
*                         for(j=last+1; j<i; j=j+1){
*                                 alpha = (x(j)-x(last))/denom
*                                 ys(j) = alpha*ys(i)+(1.0-alpha)*ys(last)
*                                 }
*                         }
*                 last = i        # last point actually estimated
*                 cut = x(last)+delta     # x coord of close points
*                 for(i=last+1; i<=n; i=i+1){     # find close points
*                         if (x(i)>cut) break     # i one beyond last pt within cut
*                         if(x(i)==x(last)){      # exact match in x
*                                 ys(i) = ys(last)
*                                 last = i
*                                 }
*                         }
*                 i=max0(last+1,i-1)
*  # back 1 point so interpolation within delta, but always go forward
*                 } until(last>=n)
*         do i = 1,n      # residuals
*                 res(i) = y(i)-ys(i)
*         if (iter>nsteps) break  # compute robustness weights except last time
*         do i = 1,n
*                 rw(i) = abs(res(i))
*         call sort(rw,n)
*         m1 = 1+n/2; m2 = n-m1+1
*         cmad = 3.0*(rw(m1)+rw(m2))      # 6 median abs resid
*         c9 = .999*cmad; c1 = .001*cmad
*         do i = 1,n {
*                 r = abs(res(i))
*                 if(r<=c1) rw(i)=1.      # near 0, avoid underflow
*                 else if(r>c9) rw(i)=0.  # near 1, avoid underflow
*                 else rw(i) = (1.0-(r/cmad)**2)**2
*                 }
*         }
*  return
*  end
*
*
*
*
*                                   LOWEST
*
*
*
*        Calling sequence
*
*        CALL LOWEST(X,Y,N,XS,YS,NLEFT,NRIGHT,W,USERW,RW,OK)
*
*        Purpose
*
*        LOWEST is a support routine for LOWESS and  ordinarily  will
*        not  be  called  by  the  user.   The  fitted  value, YS, is
*        computed  at  the  value,  XS,  of  the   horizontal   axis.
*        Robustness  weights,  RW,  can  be employed in computing the
*        fit.
*
*        Argument description
*
*
*              X = Input; abscissas of the points on the
*                  scatterplot; the values in X must be ordered
*                  from smallest to largest.
*              Y = Input; ordinates of the points on the
*                  scatterplot.
*              N = Input; dimension of X,Y,W, and RW.
*             XS = Input; value of the horizontal axis at which the
*                  smooth is computed.
*             YS = Output; fitted value at XS.
*          NLEFT = Input; index of the first point which should be
*                  considered in computing the fitted value.
*         NRIGHT = Input; index of the last point which should be
*                  considered in computing the fitted value.
*              W = Output; W(I) is the weight for Y(I) used in the
*                  expression for YS, which is the sum from
*                  I = NLEFT to NRIGHT of W(I)*Y(I); W(I) is
*                  defined only at locations NLEFT to NRIGHT.
*          USERW = Input; logical variable; if USERW is .TRUE., a
*                  robust fit is carried out using the weights in
*                  RW; if USERW is .FALSE., the values in RW are
*                  not used.
*             RW = Input; robustness weights.
*             OK = Output; logical variable; if the weights for the
*                  smooth are all 0.0, the fitted value, YS, is not
*                  computed and OK is set equal to .FALSE.; if the
*                  fitted value is computed OK is set equal to
*
*
*        Method
*
*        The smooth at XS is computed using (robust) locally weighted
*        regression of degree 1.  The tricube weight function is used
*        with h equal to the maximum of XS-X(NLEFT) and X(NRIGHT)-XS.
*        Two  cases  where  the  program  reverts to locally weighted
*        regression of degree 0 are described  in  the  documentation
*        for LOWESS.
*
*
*
*
*  subroutine lowest(x,y,n,xs,ys,nleft,nright,w,userw,rw,ok)
*  real x(n),y(n),w(n),rw(n)
*  logical userw,ok
*  range = x(n)-x(1)
*  h = amax1(xs-x(nleft),x(nright)-xs)
*  h9 = .999*h
*  h1 = .001*h
*  a = 0.0        # sum of weights
*  for(j=nleft; j<=n; j=j+1){     # compute weights (pick up all ties on right)
*         w(j)=0.
*         r = abs(x(j)-xs)
*         if (r<=h9) {    # small enough for non-zero weight
*                 if (r>h1) w(j) = (1.0-(r/h)**3)**3
*                 else      w(j) = 1.
*                 if (userw) w(j) = rw(j)*w(j)
*                 a = a+w(j)
*                 }
*         else if(x(j)>xs)break   # get out at first zero wt on right
*         }
*  nrt=j-1        # rightmost pt (may be greater than nright because of ties)
*  if (a<=0.0) ok = FALSE
*  else { # weighted least squares
*         ok = TRUE
*         do j = nleft,nrt
*                 w(j) = w(j)/a   # make sum of w(j) == 1
*         if (h>0.) {     # use linear fit
*                 a = 0.0
*                 do j = nleft,nrt
*                         a = a+w(j)*x(j) # weighted center of x values
*                 b = xs-a
*                 c = 0.0
*                 do j = nleft,nrt
*                         c = c+w(j)*(x(j)-a)**2
*                 if(sqrt(c)>.001*range) {
*  # points are spread out enough to compute slope
*                         b = b/c
*                         do j = nleft,nrt
*                                 w(j) = w(j)*(1.0+b*(x(j)-a))
*                         }
*                 }
*         ys = 0.0
*         do j = nleft,nrt
*                 ys = ys+w(j)*y(j)
*         }
*  return
*  end
*
*
*
c  test driver for lowess
c  for expected output, see introduction
      double precision x(20), y(20), ys(20), rw(20), res(20)
      data x /1,2,3,4,5,10*6,8,10,12,14,50/
      data y /18,2,15,6,10,4,16,11,7,3,14,17,20,12,9,13,1,8,5,19/
      call lowess(x,y,20,.25,0,0.,ys,rw,res)
      write(6,*) ys
      call lowess(x,y,20,.25,0,3.,ys,rw,res)
      write(6,*) ys
      call lowess(x,y,20,.25,2,0.,ys,rw,res)
      write(6,*) ys
      end
c**************************************************************
c  Fortran output from ratfor
c
      subroutine lowess(x, y, n, f, nsteps, delta, ys, rw, res)
      integer n, nsteps
      double precision x(n), y(n), f, delta, ys(n), rw(n), res(n)
      integer nright, i, j, iter, last, mid(2), ns, nleft
      double precision cut, cmad, r, d1, d2
      double precision c1, c9, alpha, denom, dabs
      logical ok
      if (n .ge. 2) goto 1
         ys(1) = y(1)
         return
c at least two, at most n points
   1  ns = max(min(int(f*dble(n)), n), 2)
      iter = 1
         goto  3
   2     iter = iter+1
   3     if (iter .gt. nsteps+1) goto  22
c robustness iterations
         nleft = 1
         nright = ns
c index of prev estimated point
         last = 0
c index of current point
         i = 1
   4        if (nright .ge. n) goto  5
c move nleft, nright to right if radius decreases
               d1 = x(i)-x(nleft)
c if d1<=d2 with x(nright+1)==x(nright), lowest fixes
               d2 = x(nright+1)-x(i)
               if (d1 .le. d2) goto  5
c radius will not decrease by move right
               nleft = nleft+1
               nright = nright+1
               goto  4
c fitted value at x(i)
   5        call lowest(x, y, n, x(i), ys(i), nleft, nright, res, iter
     +     .gt. 1, rw, ok)
            if (.not. ok) ys(i) = y(i)
c all weights zero - copy over value (all rw==0)
            if (last .ge. i-1) goto 9
               denom = x(i)-x(last)
c skipped points -- interpolate
c non-zero - proof?
               j = last+1
                  goto  7
   6              j = j+1
   7              if (j .ge. i) goto  8
                  alpha = (x(j)-x(last))/denom
                  ys(j) = alpha*ys(i)+(1.D0-alpha)*ys(last)
                  goto  6
   8           continue
c last point actually estimated
   9        last = i
c x coord of close points
            cut = x(last)+delta
            i = last+1
               goto  11
  10           i = i+1
  11           if (i .gt. n) goto  13
c find close points
               if (x(i) .gt. cut) goto  13
c i one beyond last pt within cut
               if (x(i) .ne. x(last)) goto 12
                  ys(i) = ys(last)
c exact match in x
                  last = i
  12           continue
               goto  10
c back 1 point so interpolation within delta, but always go forward
  13        i = max(last+1, i-1)
  14        if (last .lt. n) goto  4
c residuals
         do  15 i = 1, n
            res(i) = y(i)-ys(i)
  15        continue
         if (iter .gt. nsteps) goto  22
c compute robustness weights except last time
         do  16 i = 1, n
            rw(i) = dabs(res(i))
  16        continue
         call ssort(rw,n)
         mid(1) = n/2+1
         mid(2) = n-mid(1)+1
c 6 median abs resid
         cmad = 3.D0*(rw(mid(1))+rw(mid(2)))
         c9 = .999999D0*cmad
         c1 = .000001D0*cmad
         do  21 i = 1, n
            r = dabs(res(i))
            if (r .gt. c1) goto 17
               rw(i) = 1.D0
c near 0, avoid underflow
               goto  20
  17           if (r .le. c9) goto 18
                  rw(i) = 0.D0
c near 1, avoid underflow
                  goto  19
  18              rw(i) = (1.D0-(r/cmad)**2.D0)**2.D0
  19        continue
  20        continue
  21        continue
         goto  2
  22  return
      end

      subroutine lowest(x, y, n, xs, ys, nleft, nright, w, userw
     +, rw, ok)
      integer n
      integer nleft, nright
      double precision x(n), y(n), xs, ys, w(n), rw(n)
      logical userw, ok
      integer nrt, j
      double precision dabs, a, b, c, h, r
      double precision h1, dsqrt, h9, max, range
      range = x(n)-x(1)
      h = max(xs-x(nleft), x(nright)-xs)
      h9 = .999999D0*h
      h1 = .000001D0*h
c sum of weights
      a = 0.D0
      j = nleft
         goto  2
   1     j = j+1
   2     if (j .gt. n) goto  7
c compute weights (pick up all ties on right)
         w(j) = 0.D0
         r = dabs(x(j)-xs)
         if (r .gt. h9) goto 5
            if (r .le. h1) goto 3
               w(j) = (1.D0-(r/h)**3.D0)**3.D0
c small enough for non-zero weight
               goto  4
   3           w(j) = 1.D0
   4        if (userw) w(j) = rw(j)*w(j)
            a = a+w(j)
            goto  6
   5        if (x(j) .gt. xs) goto  7
c get out at first zero wt on right
   6     continue
         goto  1
c rightmost pt (may be greater than nright because of ties)
   7  nrt = j-1
      if (a .gt. 0.D0) goto 8
         ok = .false.
         goto  16
   8     ok = .true.
c weighted least squares
         do  9 j = nleft, nrt
c make sum of w(j) == 1
            w(j) = w(j)/a
   9        continue
         if (h .le. 0.D0) goto 14
            a = 0.D0
c use linear fit
            do  10 j = nleft, nrt
c weighted center of x values
               a = a+w(j)*x(j)
  10           continue
            b = xs-a
            c = 0.D0
            do  11 j = nleft, nrt
               c = c+w(j)*(x(j)-a)**2
  11           continue
            if (dsqrt(c) .le. .0000001D0*range) goto 13
               b = b/c
c points are spread out enough to compute slope
               do  12 j = nleft, nrt
                  w(j) = w(j)*(b*(x(j)-a)+1.D0)
  12              continue
  13        continue
  14     ys = 0.D0
         do  15 j = nleft, nrt
            ys = ys+w(j)*y(j)
  15        continue
  16  return
      end

      subroutine ssort(a,n)

C Sorting by Hoare method, C.A.C.M. (1961) 321, modified by Singleton
C C.A.C.M. (1969) 185.
	  double precision a(n)
	  integer iu(16), il(16)
      integer p

      i =1
      j = n
      m = 1
  5   if (i.ge.j) goto 70
c first order a(i),a(j),a((i+j)/2), and use median to split the data
 10   k=i
      ij=(i+j)/2
      t=a(ij)
      if(a(i) .le. t) goto 20
      a(ij)=a(i)
      a(i)=t
      t=a(ij)
 20   l=j
      if(a(j).ge.t) goto 40
      a(ij)=a(j)
      a(j)=t
      t=a(ij)
      if(a(i).le.t) goto 40
      a(ij)=a(i)
      a(i)=t
      t=a(ij)
      goto 40
 30   a(l)=a(k)
      a(k)=tt
 40   l=l-1
      if(a(l) .gt. t) goto 40
      tt=a(l)
c split the data into a(i to l) .lt. t, a(k to j) .gt. t
 50   k=k+1
      if(a(k) .lt. t) goto 50
      if(k .le. l) goto 30
      p=m
      m=m+1
c split the larger of the segments
      if (l-i .le. j-k) goto 60
      il(p)=i
      iu(p)=l
      i=k
      goto 80
 60   il(p)=k
      iu(p)=j
      j=l
      goto 80
 70   m=m-1
      if(m .eq. 0) return
      i =il(m)
      j=iu(m)
c short sections are sorted by bubble sort
 80   if (j-i .gt. 10) goto 10
      if (i .eq. 1) goto 5
      i=i-1
 90   i=i+1
      if(i .eq. j) goto 70
      t=a(i+1)
      if(a(i) .le. t) goto 90
      k=i
 100  a(k+1)=a(k)
      k=k-1
      if(t .lt. a(k)) goto 100
      a(k+1)=t
      goto 90

      end


c PLANCK -- Compute the Planck blackbody radiation distribution for a
c given temperature and wavelength region.
c
c       usage:  planck temperature lambda1 lambda2
c
c The temperature is specified in degrees Kelvin and the wavelength
c region in microns (1u=10000A).  100 [x,y] data points defining the
c curve are output.
c ----------------------------------------------------------------------

        program planck

	character*80	errmsg
        integer         nargs, ier, i
        real            w1, w2, dw, cm, t
        real            xv(100), yv(100)

c --- Get the temperature in degrees kelvin.
        call clargr (1, t, ier)
        if (ier .ne. 0) then
            write (*, '('' temperature (degrees kelvin): '',$)')
            read (*,*) t
        endif

c --- Get the wavelength region to be computed.
        call clnarg (nargs)
        if (nargs .ge. 3) then
            call clargr (2, w1, ier)
            if (ier .ne. 0) goto 91
            call clargr (3, w2, ier)
            if (ier .ne. 0) goto 91
        else
            write (*, '('' start wavelength (microns): '',$)')
            read (*,*) w1
            write (*, '('' end wavelength (microns): '',$)')
            read (*,*) w2
        endif

c --- Compute the blackbody curve.
        dw = (w2 - w1) / 99.0
        do 10 i = 1, 100
            xv(i) = ((i-1) * dw) + w1
            cm = xv(i) * 1.0E-4
            yv(i) = (3.74185E-5 * (cm ** -5)) /
     *          (2.71828 ** (1.43883 / (cm * t)) - 1.0)
 10	continue

c --- Print the curve as a table.
        do 20 i = 1, 100
	    write (*, '(1x, f7.4, g12.4)') xv(i), yv(i)
 20	continue

	stop

c --- Error exit.
 91	call imemsg (ier, errmsg)
	write (*, '('' Error: '', a80)') errmsg
	stop
	end


!****************************************************************
!*     Purpose: This program computes the spherical Bessel      *
!*              functions jn(x) and jn'(x) using subroutine     *
!*              SPHJ                                            *
!*     Input :  x --- Argument of jn(x)                         *
!*              n --- Order of jn(x)  ( n = 0 to 250 )          *
!*     Output:  SJ(n) --- jn(x)                                 *
!*              DJ(n) --- jn'(x)                                *
!*     Example:   x =10.0                                       *
!*                n          jn(x)              jn'(x)          *
!*              --------------------------------------------    *
!*                0    -.5440211109D-01    -.7846694180D-01     *
!*                1     .7846694180D-01    -.7009549945D-01     *
!*                2     .7794219363D-01     .5508428371D-01     *
!*                3    -.3949584498D-01     .9374053162D-01     *
!*                4    -.1055892851D+00     .1329879757D-01     *
!*                5    -.5553451162D-01    -.7226857814D-01     *
!* ------------------------------------------------------------ *
!* REFERENCE: "Fortran Routines for Computation of Special      *
!*             Functions,                                       *
!*             jin.ece.uiuc.edu/routines/routines.html".        *
!*                                                              *
!*                            F90 Release By J-P Moreau, Paris. *
!*                                   (www.jpmoreau.fr)          *
!****************************************************************
!        PROGRAM MSPHJ
!        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
!        DIMENSION SJ(0:250),DJ(0:250)
!        WRITE(*,*)'Please enter n and x '
!        READ(*,*)N,X
!        WRITE(*,30)N,X
!        IF (N.LE.10) THEN
!           NS=1
!        ELSE
!           WRITE(*,*)'Please enter order step Ns'
!           READ(*,*)NS
!        ENDIF
!        CALL SPHJ(N,X,NM,SJ,DJ)
!        WRITE(*,*)
!        WRITE(*,*)'  n          jn(x)               jn''(x)'
!        WRITE(*,*)'--------------------------------------------'
!        DO 10 K=0,NM,NS
!10         WRITE(*,20)K,SJ(K),DJ(K)
!20      FORMAT(1X,I3,2D20.10)
!30      FORMAT(3X,6HNmax =,I3,',     ',2Hx=,F5.1)
!        END

        MODULE msphj
        CONTAINS

        SUBROUTINE SPHJ(N,X,NM,SJ,DJ)

!      =======================================================
!      Purpose: Compute spherical Bessel functions jn(x) and
!               their derivatives
!      Input :  x --- Argument of jn(x)
!               n --- Order of jn(x)  ( n = 0,1,תתת )
!      Output:  SJ(n) --- jn(x)
!               DJ(n) --- jn'(x)
!               NM --- Highest order computed
!      Routines called:
!               MSTA1 and MSTA2 for computing the starting
!               point for backward recurrence
!      =======================================================

        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        DIMENSION SJ(0:N),DJ(0:N)
        NM=N
        IF (DABS(X).EQ.1.0D-100) THEN
           DO 10 K=0,N
              SJ(K)=0.0D0
10            DJ(K)=0.0D0
           SJ(0)=1.0D0
           DJ(1)=.3333333333333333D0
           RETURN
        ENDIF
        SJ(0)=DSIN(X)/X
        SJ(1)=(SJ(0)-DCOS(X))/X
        IF (N.GE.2) THEN
           SA=SJ(0)
           SB=SJ(1)
           M=MSTA1(X,200)
           IF (M.LT.N) THEN
              NM=M
           ELSE
              M=MSTA2(X,N,15)
           ENDIF
           F0=0.0D0
           F1=1.0D0-100
           DO 15 K=M,0,-1
              F=(2.0D0*K+3.0D0)*F1/X-F0
              IF (K.LE.NM) SJ(K)=F
              F0=F1
15            F1=F
           IF (DABS(SA).GT.DABS(SB)) CS=SA/F
           IF (DABS(SA).LE.DABS(SB)) CS=SB/F0
           DO 20 K=0,NM
20            SJ(K)=CS*SJ(K)
        ENDIF
        DJ(0)=(DCOS(X)-DSIN(X)/X)/X
        DO 25 K=1,NM
25         DJ(K)=SJ(K-1)-(K+1.0D0)*SJ(K)/X
        RETURN
        END

        INTEGER FUNCTION MSTA1(X,MP)

!      ===================================================
!      Purpose: Determine the starting point for backward
!               recurrence such that the magnitude of
!               Jn(x) at that point is about 10^(-MP)
!      Input :  x     --- Argument of Jn(x)
!               MP    --- Value of magnitude
!      Output:  MSTA1 --- Starting point
!      ===================================================

        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        A0=DABS(X)
        N0=INT(1.1*A0)+1
        F0=ENVJ(N0,A0)-MP
        N1=N0+5
        F1=ENVJ(N1,A0)-MP
        DO 10 IT=1,20
           NN=N1-(N1-N0)/(1.0D0-F0/F1)
           F=ENVJ(NN,A0)-MP
           IF(ABS(NN-N1).LT.1) GO TO 20
           N0=N1
           F0=F1
           N1=NN
 10        F1=F
 20     MSTA1=NN
        RETURN
        END

        INTEGER FUNCTION MSTA2(X,N,MP)

!      ===================================================
!      Purpose: Determine the starting point for backward
!               recurrence such that all Jn(x) has MP
!               significant digits
!      Input :  x  --- Argument of Jn(x)
!               n  --- Order of Jn(x)
!               MP --- Significant digit
!      Output:  MSTA2 --- Starting point
!      ===================================================

        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        A0=DABS(X)
        HMP=0.5D0*MP
        EJN=ENVJ(N,A0)
        IF (EJN.LE.HMP) THEN
           OBJ=MP
           N0=INT(1.1*A0)
        ELSE
           OBJ=HMP+EJN
           N0=N
        ENDIF
        F0=ENVJ(N0,A0)-OBJ
        N1=N0+5
        F1=ENVJ(N1,A0)-OBJ
        DO 10 IT=1,20
           NN=N1-(N1-N0)/(1.0D0-F0/F1)
           F=ENVJ(NN,A0)-OBJ
           IF (ABS(NN-N1).LT.1) GO TO 20
           N0=N1
           F0=F1
           N1=NN
10         F1=F
20      MSTA2=NN+10
        RETURN
        END

        REAL*8 FUNCTION ENVJ(N,X)
        DOUBLE PRECISION X
        ENVJ=0.5D0*DLOG10(6.28D0*N)-N*DLOG10(1.36D0*X/N)
        RETURN
        END

        END MODULE

!end of file msphj.f90


program solver
    use Utils
    use Types
    use MKL_wrapper
    use gausets
    implicit none
    integer(4) NMAX
    !PARAMETER        ( NMAX = 10000 )
    complex(8), dimension(:,:), allocatable :: RA, RB

	complex(8), dimension (:,:), allocatable :: MA
	complex(8), dimension (:,:), allocatable :: MB

	complex(DPT), dimension (:,:), allocatable :: A
	complex(DPT), dimension (:,:), allocatable :: B

	integer, dimension( 4 )  ::	ISEED

    CHARACTER(len=32) :: arg
    integer stat
    integer(4) N

    real time_init, time_mkl, time_gauset
    real T1,T2
    print *, 'Solve the complex equations A*X = B.'
    print *, 'and calc exec time'
    CALL getarg(1, arg)
    READ(arg,*,iostat=stat)N
    if (stat<0) then
       print *, "set default size"
       N = 4
    end if
    print *, "N=", N

    NMAX = 2*N

    allocate ( RA(NMAX, NMAX) )
    allocate ( RB(NMAX, 1) )

    call random_z(NMAX,	RB)
    call random_z(NMAX*NMAX,	RA)

    MA = RA(1:N, 1:N)
    MB = RB(1:N, 1:1)

    time_init = sys_time()
    !call cpu_time(T1)

    call mkl_le_solver(MA,MB)

    !call cpu_time(T2)
    time_mkl = sys_time() - time_init

    print *, 'mkl_le_solver exec time',  time_mkl, T2-T1
    print *, "---------"

    A = RA(1:N, 1:N)
    B = RB(1:N, 1:1)
    time_init = sys_time()
    call gauset (A,B)
    time_gauset = sys_time() - time_init

    print *, "---------"

    print *,'Err sum: ', SUM(CDABS(B-MB))
    print *,'Time ratio: ',time_gauset/time_mkl

end program  solver


 SUBROUTINE colsol(a,maxa,neq,task,iw,ish,nsymm,v,u)
 !.....................................................................
 !.                                                                   .
 !.   P R O G R A M                                                   .
 !.     TO SOLVE EQUILIBRIUM EQUATIONS FROM FINITE ELEMENTS           .
 !.     IN FAST MEMORY USING COMPACT STORAGE WITH SKYLINE SCHEME      .
 !.                                                                   .
 !.  --INPUT VARIABLE                                                 .
 !.     A(:)     = STIFFNES MATRIX IN COMPACT FORM                    .
 !.     V(NEQ)   = LOADING VECTOR                                     .
 !.     MAXA(NEQ+1)= VECTOR CONTAINING THE DIAGONAL POSITIONS IN A    .
 !.     NEQ      = NUMBER OF EQUATION                                 .
 !.     TASK     = FLAG                                               .
 !.          EQ. 1 MATRIX FACTORIZATION                               .
 !.          EQ. 2 BACK SUBSTITUTION OF VECTOR V                      .
 !.     IW       = NUMBER ASSOCIATED TO OUTPUT DEVICE FOR MESSAGES    .
 !.     ISH      = FLAG TO INDICATE IF NON-POSSITIVE MATRICES ALLOWED .
 !.          EQ. 0   ONLY POSSITIVE MATRICES ALLOWED                  .
 !.          EQ. 1   ANY NON-SINGULAR MATRIZ ALLOWED                  .
 !.     NSYMM    = INDICATES IF MATRIZ IS SYMMETRIC                   .
 !.          EQ. 0   SYMMETRIC MATRIX                                 .
 !.          EQ. 1   NON-SYMMETRIC MATRIX                             .
 !.     IN THE LAST CASE                                              .
 !.        U(:)  = UPPER PART OF THE NON-SYMMETRIC MATRIX             .
 !.                                                                   .
 !.-- OUTPUT                                                          .
 !.     TASK = 1                                                      .
 !.        A(:)  = D & L - FACTOR OF THE STIFFNES MATRIX              .
 !.        U(:)  = UPPER TRIANGULAR FACTOR FOR NON-SYMMETRIC MATRIX   .
 !.     TASK = 2                                                      .
 !.        V(NEQ) = EQUATION SOLUTION                                 .
 !.                                                                   .
 !.....................................................................
 IMPLICIT NONE
 !.....................................................................
 INTEGER (kind=4),INTENT(IN) :: neq,task,iw,ish,maxa(:),nsymm
 REAL (kind=8),INTENT(IN OUT) :: a(:)
 REAL (kind=8),INTENT(IN OUT), OPTIONAL :: u(:),v(:)
 !Local Variables
 INTEGER (kind=4) :: n,kn,kl,ku,k,ic,klt,ki,nd,l,kh,j,kk
 REAL (kind=8) :: b,c,d
 !
 IF(task == 1) THEN

   ! L*D*U Factorization of Stiffness Matrix

   IF(nsymm == 0 .OR. nsymm == -1) THEN   ! U = L(T)
     DO n=1,neq                            !para cada fila i==N
       kn = maxa(n)                       !pos. de K(i,i)
       kl = kn+1                          !pos. de K(i,i-1)
       ku = maxa(n+1)-1                   !pos.del 1ro de la fila K(i,Jmin)
       kh = ku-kl                         !long de la fila sin extremos
       IF(kh > 0) THEN                    !si hay val.de g(i,j) a calcular
         k = n - kh                       !ec. asoc. al 1ro de la fila Jmin
         ic = 0                           !contador
         klt = ku                         !pos del el (i,j) = (i,Jmin)
         DO j=1,kh                        !calculo de los g(i,j)
           ic = ic + 1                    !num de terminos de la sumatoria
           klt = klt - 1                  !pos de g(i,j)
           ki = maxa(k)                   !pos de d(j,j)
           nd = maxa(k+1) - ki - 1        !long. fila j - diagonal
           IF(nd > 0) THEN                !num de terminos de la sumatoria
             kk = MIN(ic,nd)              !numero definitivo de terminos
             c = 0.d0                     !pone a 0 el acumulador
             DO l=1,kk                    ! KI+L==(j,j-l)  KLT+L==(i,j-l)
               c = c + a(ki+l)*a(klt+l)   !+l(j,k)*g(i,k)
             END DO
             a(klt) = a(klt) - c          !g(i,j) --> A
           END IF
           k = k + 1                      !pasa a la siguiente col. k==j
         END DO
       END IF
       IF(kh >= 0) THEN                   !si hay el. fuera de la diagonal
         k = n                            !K==j   N==i  --> j=i
         b = 0.d0                         !pone a 0 el acumulador diag.
         DO kk=kl,ku                      !para c/ter. no diag.
           k = k - 1                      !decrementa j (hasta Jmin)
           ki = maxa(k)                   !pos. de d(j,j)
           c = a(kk)/a(ki)                !l(i,j)=g(i,j)/d(j,j)
           b = b + c*a(kk)                !+l(i,j)*g(i,j)
           a(kk) = c                      !l(j,i) --> A
         END DO
         a(kn) = a(kn) - b                !d(n,n) --> A
       END IF
       IF(a(kn) <= 0) THEN
         IF(ish == 0) THEN
           WRITE(iw,8000)
           WRITE(iw,8020)n,a(kn)
           STOP
         ELSE
           WRITE(iw,8020) n,a(kn)
           IF(a(kn) == 0) a(kn) = 1.d-16
         END IF
       END IF
     END DO
   ELSE                                   ! U <> L(T)
     DO n=1,neq                            !para cada fila i==N
       kn = maxa(n)                       !pos. de K(i,i)
       kl = kn + 1                        !pos. de K(i,i-1) y U(i-1,i)
       ku = maxa(n+1) - 1                 !pos.de K(Jmin,i) y U(i,Jmin)
       kh = ku - kl                       !long. de la fila sin extremos
       IF(kh > 0) THEN                    !si hay val.de g(i,j) a calcular
         k = n - kh                       !ec. asoc. al 1ro de la fila Jmin
         ic = 0                           !contador
         klt = ku                         !pos del el (i,j) = (i,Jmin)
         DO j=1,kh                        !calculo de los g(i,j) y f(j,i)
           ic = ic + 1                    !num de terminos de la sumatoria
           klt = klt - 1                  !pos de g(i,j) y f(j.i)
           ki = maxa(k)                   !pos de d(j,j)
           nd = maxa(k+1) - ki - 1        !long. fila j - diagonal
           IF(nd > 0) THEN                !num de terminos de la sumatoria
             kk = MIN(ic,nd)              !numero definitivo de terminos
             c = 0.d0                     !pone a 0 el acumulador de g(i.j)
             d = 0.d0                     !pone a 0 el acumulador de f(j.i)
             DO l=1,kk                    ! KI+L==(j,j-l)  KLT+L==(i,j-l)
               c = c + u(ki+l)*a(klt+l)   !+u(k,j)*g(i,k)
               d = d + a(ki+l)*u(klt+l)   !+l(j,k)*f(k,i)
             END DO
             a(klt) = a(klt) - c          !g(i,j) --> A
             u(klt) = u(klt) - d          !f(j,i) --> U
           END IF
           k = k + 1                      !pasa a la siguiente col. k==j
         END DO
       END IF
       IF(kh >= 0) THEN                   !si hay el. fuera de la diagonal
         k = n                            !K==j   N==i  --> j=i
         b = 0.d0                         !pone a 0 el acumulador diag.
         DO kk=kl,ku                      !para c/ter. no diag.
           k = k - 1                      !decrementa j (hasta Jmin)
           ki = maxa(k)                   !pos. de d(j,j)
           c = a(kk)/a(ki)                !l(i,j)=g(i,j)/d(j,j)
           d = u(kk)/a(ki)                !u(j,i)=f(j,i)/d(j,j)
           b = b + c*u(kk)                !+l(i,j)*f(j,i)
           a(kk) = c                      !l(i,j) --> A
           u(kk) = d                      !u(j,i) --> U
         END DO
         a(kn) = a(kn) - b                !d(i,i) --> A
       END IF
       IF(a(kn) <= 0) THEN
         IF(ish == 0) THEN
           WRITE(iw,8000)
           WRITE(iw,8020) n,a(kn)
           STOP
         ELSE
           WRITE(iw,8020) n,a(kn)
           IF(a(kn) == 0) a(kn) = 1.d-16
         END IF
       END IF
     END DO
   END IF
   !       d = MINVAL(a(maxa(1:neq)))
   !       WRITE(IW,"(' minimum pivot =',e15.4)")d
 ELSE

   !   Reduce Independent vector

   DO n=1,neq
     kl = maxa(n)+1
     ku = maxa(n+1)-1
     IF(ku-kl >= 0) THEN
       k = n
       c = 0.d0
       DO kk=kl,ku
         k = k-1
         c = c + a(kk)*v(k)
       END DO
       v(n) = v(n) - c
     END IF
   END DO

   !       Back-Substitution

   DO n=1,neq
     k = maxa(n)
     v(n) = v(n)/a(k)
   END DO
   n = neq
   IF(nsymm == 0 .OR. nsymm == -1) THEN   ! Symmetric Matrix
     DO l=2,neq
       kl = maxa(n)+1
       ku = maxa(n+1)-1
       k  = n
       DO kk=kl,ku
         k = k-1
         v(k) = v(k) - a(kk)*v(n)
       END DO
       n = n-1
     END DO
   ELSE                                   !Non-symmetric matrix
     DO l=2,neq
       kl = maxa(n)+1
       ku = maxa(n+1)-1
       k = n
       DO kk=kl,ku
         k = k - 1
         v(k) = v(k) - u(kk)*v(n)
       END DO
       n = n-1
     END DO
   END IF

 END IF
 8000 FORMAT(//,'   STOP - Non-Positive Stiffness Matrix ',//)
 8020 FORMAT('   Non-positive pivot for equation',I5,'  PIVOT=',E20.12)

 RETURN
 END SUBROUTINE colsol


!------------------------------------------------------------------------
      subroutine ncperiodogram_no_norm(ht, st, rc, ic, dim)
! Calculates a cross spectrum between the time series ht(int_len_dim) and st(int_len_dim)
! Phase is such that +ve lag corresponds to ht lagging st
! ***MODIFIED*** from Press et al (1992) DFT definition, this is S^*(\nu)H(\nu)
        ! use dyn_lc
        implicit none
        integer, intent(IN)  :: dim
        double precision , intent(IN)  :: ht(dim), st(dim)
        double precision , intent(OUT) :: rc(dim / 2), ic(dim / 2)
        integer              :: j
        double precision , allocatable :: datah(:), datas(:)
        if (.not. allocated(datah)) allocate(datah(2 * dim))
        if (.not. allocated(datas)) allocate(datas(2 * dim))

        do j = 1, dim
           datah(2 * j - 1) = ht(j)
           datah(2 * j)     = 0.d0
           datas(2 * j - 1) = st(j)
           datas(2 * j)     = 0.d0
        end do
        call four1(datah, dim, 1)
        call four1(datas, dim, 1)

        do j = 1, dim / 2
           rc(j) = datah(2 * j + 1) * datas(2 * j + 1) + datah(2 * j + 2) * datas(2 * j + 2)
           ic(j) = datah(2 * j + 2) * datas(2 * j + 1) - datah(2 * j + 1) * datas(2 * j + 2)

        end do
        if (allocated(datah)) deallocate(datah)
        if (allocated(datas)) deallocate(datas)
        return
      end subroutine ncperiodogram_no_norm
!------------------------------------------------------------------------

!------------------------------------------------------------------------
      subroutine periodogram_no_norm(time_series, pw, dim)
! Calculates power spectrum of the time series lc(dim)
! ***MODIFIED*** from Press et al (1992) DFT definition
        ! use dyn_lc
        implicit none
        integer, intent(IN)  :: dim
        double precision , intent(IN)  :: time_series(dim)
        double precision , intent(OUT) :: pw(dim / 2)

        integer              :: j
        double precision ,allocatable  :: datah(:)

        if (.not. allocated(datah)) allocate(datah(2 * dim))
        ! sum = 0.d0

        do j = 1, dim
           datah(2 * j - 1) = time_series(j)
           datah(2 * j)   = 0.d0
        end do

        call four1(datah, dim, 1)

        do j = 1, dim / 2
          pw(j) = (datah(2 * j + 1)**2 + datah(2 * j + 2 )**2)
        end do

        if (allocated(datah)) deallocate(datah)
        return
      end subroutine periodogram_no_norm
!------------------------------------------------------------------------

!------------------------------------------------------------------------
      subroutine ncperiodogram_frac_rms(ht, st, rc, ic, dt, dim)
! Calculates a cross spectrum between the time series ht(int_len_dim) and st(int_len_dim)
! In fractional  rms normalisation
! Phase is such that +ve lag corresponds to ht lagging st
! ***MODIFIED*** from Press et al (1992) DFT definition, this is S^*(\nu)H(\nu)
        ! use dyn_lc
        implicit none
        integer, intent(IN)  :: dim
        double precision , intent(IN)  :: dt, ht(dim), st(dim)
        double precision , intent(OUT) :: rc(dim / 2), ic(dim / 2)
        integer              :: j
        double precision               :: meanh, means
        double precision , allocatable :: datah(:), datas(:)
        if (.not. allocated(datah)) allocate(datah(2 * dim))
        if (.not. allocated(datas)) allocate(datas(2 * dim))

        do j = 1, dim
           datah(2 * j - 1) = ht(j)
           datah(2 * j)     = 0.d0
           datas(2 * j - 1) = st(j)
           datas(2 * j)     = 0.d0
        end do
        call four1(datah, dim, 1)
        call four1(datas, dim, 1)

        meanh = datah(1) / dim
        means = datas(1) / dim

        do j = 1, dim / 2
           rc(j) = datah(2 * j + 1) * datas(2 * j + 1) + datah(2 * j + 2) * datas(2 * j + 2)
           rc(j) = rc(j) * 2.d0 * dt / (dble(dim) * meanh * means)
           ic(j) = datah(2 * j + 2) * datas(2 * j + 1) - datah(2 * j + 1) * datas(2 * j + 2)
           ic(j) = ic(j) *  2.d0 * dt / (dble(dim) * meanh * means)

        end do
        if (allocated(datah)) deallocate(datah)
        if (allocated(datas)) deallocate(datas)
        return
      end subroutine ncperiodogram_frac_rms
!------------------------------------------------------------------------

!------------------------------------------------------------------------
      subroutine periodogram_frac_rms(time_series, pw, dt, dim)
! Calculates power spectrum of the time series lc(dim)
! In fractional  rms normalisation
! ***MODIFIED*** from Press et al (1992) DFT definition
        ! use dyn_lc
        implicit none
        integer, intent(IN)  :: dim
        double precision , intent(IN)  :: dt, time_series(dim)
        double precision , intent(OUT) :: pw(dim / 2)

        integer              :: j
        double precision               :: mean !sum, var
        double precision ,allocatable  :: datah(:)

        if (.not. allocated(datah)) allocate(datah(2 * dim))
        ! sum = 0.0

        do j = 1, dim
           datah(2 * j - 1) = time_series(j)
           datah(2 * j)   = 0.d0
        end do

        call four1(datah, dim, 1)
        mean = datah(1) / dim

        do j = 1, dim / 2
          pw(j) = (datah(2 * j + 1)**2 + datah(2 * j + 2 )**2) * 2. * dt / (float(dim) * mean**2)
        end do

        if (allocated(datah)) deallocate(datah)
        return
      end subroutine periodogram_frac_rms
!------------------------------------------------------------------------

!------------------------------------------------------------------------
      subroutine ncperiodogram(ht, st, rc, ic, dt, dim)
! Calculates a cross spectrum between the time series ht(int_len_dim) and st(int_len_dim)
! In absolute  rms normalisation
! Phase is such that +ve lag corresponds to ht lagging st
! ***MODIFIED*** from Press et al (1992) DFT definition, this is S^*(\nu)H(\nu)
        ! use dyn_lc
        implicit none
        integer, intent(IN)  :: dim
        double precision , intent(IN)  :: dt, ht(dim), st(dim)
        double precision , intent(OUT) :: rc(dim / 2), ic(dim / 2)
        integer              :: j
        double precision               :: meanh, means
        double precision , allocatable :: datah(:), datas(:)
        if (.not. allocated(datah)) allocate(datah(2 * dim))
        if (.not. allocated(datas)) allocate(datas(2 * dim))

        do j = 1, dim
           datah(2 * j - 1) = ht(j)
           datah(2 * j)     = 0.d0
           datas(2 * j - 1) = st(j)
           datas(2 * j)     = 0.d0
        end do
        call four1(datah, dim, 1)
        call four1(datas, dim, 1)

        meanh = datah(1) / dim
        means = datas(1) / dim

        do j = 1, dim / 2
           rc(j) = datah(2 * j + 1) * datas(2 * j + 1) + datah(2 * j + 2) * datas(2 * j + 2)
           rc(j) = rc(j) * 2.d0 * dt / (dble(dim) )
           ic(j) = datah(2 * j + 2) * datas(2 * j + 1) - datah(2 * j + 1) * datas(2 * j + 2)
           ic(j) = ic(j) *  2.d0 * dt / (dble(dim))

        end do
        if (allocated(datah)) deallocate(datah)
        if (allocated(datas)) deallocate(datas)
        return
    end subroutine ncperiodogram
!------------------------------------------------------------------------

!------------------------------------------------------------------------
      subroutine periodogram(time_series, pw, dt, dim)
! Calculates power spectrum between the time series lc(dim)
! In absolute  rms normalisation
! Phase is such that +ve lag corresponds to ht lagging st
! ***MODIFIED*** from Press et al (1992) DFT definition
        ! use dyn_lc
        implicit none
        integer, intent(IN)  :: dim
        double precision , intent(IN)  :: dt, time_series(dim)
        double precision , intent(OUT) :: pw(dim / 2)

        integer              :: j
        ! double precision               :: mean, sum, var
        double precision ,allocatable  :: datah(:)

        if (.not. allocated(datah)) allocate(datah(2 * dim))
        ! sum = 0.0
        do j = 1, dim
           ! sum = sum + time_series(j)**2
           datah(2 * j - 1) = time_series(j)
           datah(2 * j)   = 0.d0
        end do

        call four1(datah, dim, 1)
        ! mean = datah(1) / dim
        ! write(*,*) 'mean ', mean

        do j = 1, dim / 2
           pw(j) = (datah(2 * j + 1)**2 + datah(2 * j + 2 )**2) * 2.d0 * dt / (float(dim))
        end do

!Check the Parseval theorem
        ! sum = 0.d0
        ! do j = 1, dim
        !    sum = sum + time_series(j)**2
        ! enddo
        ! var = 0.d0
        ! do j = 0, dim - 1
        !    !           write(*,*) 2 * j + 1, 2 * j + 2
        !    var = var + datah(2 * j + 1)**2 + datah(2 * j + 2 )**2
        !    ! write(111,*) j, datah(2 * j + 1)**2 + datah(2 * j + 2 )**2
        ! enddo
        ! var = var / dim

        ! write(*,*)  'Parseval theorem'
        ! write(*,*)  sum, var

        ! ! var = 0.0
        ! ! do j = 1, dim / 2
        ! !    var = var + pw(j)
        ! ! enddo
        ! ! var = (2 * var + datah(1)**2)  / dim
        ! ! write(*,*)  'Parcival theorem'
        ! ! write(*,*)  sum, var

        if (allocated(datah)) deallocate(datah)
        return
      end subroutine periodogram
!------------------------------------------------------------------------

!------------------------------------------------------------------------
      subroutine periodogram_leahy(ht, pw, dt, dim)
! Calculates power spectrum between the time series ht(int_len_dim)
! In leahy normalisation
! Phase is such that +ve lag corresponds to ht lagging st
! ***MODIFIED*** from Press et al (1992) DFT definition
        ! use dyn_lc
        implicit none
        integer          , intent(IN)  :: dim
        double precision , intent(IN)  :: ht(dim), dt
        double precision , intent(OUT) :: pw(dim / 2)

        integer              :: j
        ! double precision               :: sum!, var sum2, par
        double precision ,allocatable  :: datah(:)

        if (.not. allocated(datah)) allocate(datah(2 * dim))
        ! sum  = 0.0
        ! sum2 = 0.0
        do j = 1, dim
           ! sum  = sum  + ht(j)
           ! sum2 = sum2 + ht(j)**2
           datah(2 * j - 1) = ht(j)
           datah(2 * j)   = 0.d0
        end do
        call four1(datah, dim, 1)

        ! write(*,*) ' number of photons: ', sum, datah(1)

        do j = 1, dim / 2
           pw(j) = (datah(2 * j + 1)**2 + datah(2 * j + 2 )**2) * 2.d0 * dt / datah(1)
           ! write(11, *) j, pw(j)
        end do
        ! write(11, *) 'no no'

!Check the Parseval theorem
        ! par = 0.d0
        ! do j = 0, dim - 1
        !    !           write(*,*) 2 * j + 1, 2 * j + 2
        !    par = par + datah(2 * j + 1)**2 + datah(2 * j + 2 )**2
        !    ! write(111,*) j, datah(2 * j + 1)**2 + datah(2 * j + 2 )**2
        ! enddo
        ! par = par / dble(dim)

        ! write(*,*)  'Parseval theorem'
        ! write(*,*)  sum2, par

! !CHECK THE VARIANCE CALCULATION

! !First the variance from the light curve
!         var = (sum2 / dble(dim)) - (sum / dble(dim))**2
!         write(*,*) 'variance from lc', var

! !Then variance from the fourier transform
!         var = 0.d0
!         do j = 1, dim - 1
!            var = var + datah(2 * j + 1)**2 + datah(2 * j + 2 )**2
!         enddo
!         var = var / dble(dim)
!         write(*,*) 'variance from ft', var

!         ! do j = 0, dim - 1
!         !    write(10,*) j, datah(2 * j + 1)
!         ! enddo
!         ! write(10, *) 'no no'

        if (allocated(datah)) deallocate(datah)
        return
      end subroutine periodogram_leahy
!------------------------------------------------------------------------

!-----------------------------------------------------------------------
      SUBROUTINE four1(data,nn,isign)
      INTEGER isign,nn
      DOUBLE PRECISION data(2*nn)
      INTEGER i,istep,j,m,mmax,n
      DOUBLE PRECISION tempi,tempr
      DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp
      n=2*nn
      j=1
      ! write(*,*) 'ciao ciao '

      ! do i = 1, nn
      !    write(*,*) i, data(2 * i - 1), data(2 * i)
      ! enddo
      ! write(*,*) 'ciao ciao '

      do 11 i=1,n,2
        if(j.gt.i)then
          tempr=data(j)
          tempi=data(j+1)
          data(j)=data(i)
          data(j+1)=data(i+1)
          data(i)=tempr
          data(i+1)=tempi
        endif
        m=n/2
1       if ((m.ge.2).and.(j.gt.m)) then
          j=j-m
          m=m/2
        goto 1
        endif
        j=j+m
11    continue
      mmax=2
2     if (n.gt.mmax) then
        istep=2*mmax
        theta=6.28318530717959d0/(isign*mmax)
        wpr=-2.d0*sin(0.5d0*theta)**2
        wpi=sin(theta)
        wr=1.d0
        wi=0.d0
        do 13 m=1,mmax,2
          do 12 i=m,n,istep
            j=i+mmax
            tempr=sngl(wr)*data(j)-sngl(wi)*data(j+1)
            tempi=sngl(wr)*data(j+1)+sngl(wi)*data(j)
            data(j)=data(i)-tempr
            data(j+1)=data(i+1)-tempi
            data(i)=data(i)+tempr
            data(i+1)=data(i+1)+tempi
12        continue
          wtemp=wr
          wr=wr*wpr-wi*wpi+wr
          wi=wi*wpr+wtemp*wpi+wi
13      continue
        mmax=istep
      goto 2
      endif
      return
      end
!---------------------------------------------------------------

!----------------------------------------------------------------
      subroutine ncperiodogram_no_norm_real(ht, st, rc, ic, dim)
! Calculates a cross spectrum between the time series ht(int_len_dim) and st(int_len_dim)
! Phase is such that +ve lag corresponds to ht lagging st
! ***MODIFIED*** from Press et al (1992) DFT definition, this is S^*(\nu)H(\nu)
        use dyn_lc
        implicit none
        integer, intent(IN)  :: dim
        real   , intent(IN)  :: ht(dim), st(dim)
        real   , intent(OUT) :: rc(dim / 2), ic(dim / 2)
        integer              :: j
        real   , allocatable :: datah(:), datas(:)
        if (.not. allocated(datah)) allocate(datah(2 * dim))
        if (.not. allocated(datas)) allocate(datas(2 * dim))

        do j = 1, dim
           datah(2 * j - 1) = ht(j)
           datah(2 * j)     = 0.0
           datas(2 * j - 1) = st(j)
           datas(2 * j)     = 0.0
        end do
        call four1_real(datah, dim, 1)
        call four1_real(datas, dim, 1)

        do j = 1, dim / 2
           rc(j) = datah(2 * j + 1) * datas(2 * j + 1) + datah(2 * j + 2) * datas(2 * j + 2)
           ic(j) = datah(2 * j + 2) * datas(2 * j + 1) - datah(2 * j + 1) * datas(2 * j + 2)

        end do
        if (allocated(datah)) deallocate(datah)
        if (allocated(datas)) deallocate(datas)
        return
      end subroutine ncperiodogram_no_norm_real
!-----------------------------------------------------------------

!-----------------------------------------------------------------
      subroutine periodogram_no_norm_real(time_series, pw, dim)
! Calculates power spectrum of the time series lc(dim)
! ***MODIFIED*** from Press et al (1992) DFT definition
        use dyn_lc
        implicit none
        integer, intent(IN)  :: dim
        real   , intent(IN)  :: time_series(dim)
        real   , intent(OUT) :: pw(dim / 2)

        integer              :: j
        real   ,allocatable  :: datah(:)

        if (.not. allocated(datah)) allocate(datah(2 * dim))
        ! sum = 0.0

        do j = 1, dim
           datah(2 * j - 1) = time_series(j)
           datah(2 * j)   = 0.0
        end do

        call four1_real(datah, dim, 1)

        do j = 1, dim / 2
          pw(j) = (datah(2 * j + 1)**2 + datah(2 * j + 2 )**2)
        end do

        if (allocated(datah)) deallocate(datah)
        return
      end subroutine periodogram_no_norm_real
!-------------------------------------------------------------------

!-------------------------------------------------------------------
      subroutine ncperiodogram_frac_rms_real(ht, st, rc, ic, dim)
! Calculates a cross spectrum between the time series ht(int_len_dim) and st(int_len_dim)
! In fractional  rms normalisation
! Phase is such that +ve lag corresponds to ht lagging st
! ***MODIFIED*** from Press et al (1992) DFT definition, this is S^*(\nu)H(\nu)
        use dyn_lc
        implicit none
        integer, intent(IN)  :: dim
        real   , intent(IN)  :: ht(dim), st(dim)
        real   , intent(OUT) :: rc(dim / 2), ic(dim / 2)
        integer              :: j
        real                 :: meanh, means
        real   , allocatable :: datah(:), datas(:)
        if (.not. allocated(datah)) allocate(datah(2 * dim))
        if (.not. allocated(datas)) allocate(datas(2 * dim))

        do j = 1, dim
           datah(2 * j - 1) = ht(j)
           datah(2 * j)     = 0.0
           datas(2 * j - 1) = st(j)
           datas(2 * j)     = 0.0
        end do
        call four1_real(datah, dim, 1)
        call four1_real(datas, dim, 1)

        meanh = datah(1) / dim
        means = datas(1) / dim

        do j = 1, dim / 2
           rc(j) = datah(2 * j + 1) * datas(2 * j + 1) + datah(2 * j + 2) * datas(2 * j + 2)
           rc(j) = rc(j) * 2. * real(dt) / (real(dim) * meanh * means)
           ic(j) = datah(2 * j + 2) * datas(2 * j + 1) - datah(2 * j + 1) * datas(2 * j + 2)
           ic(j) = ic(j) *  2. * real(dt) / (real(dim) * meanh * means)

        end do
        if (allocated(datah)) deallocate(datah)
        if (allocated(datas)) deallocate(datas)
        return
      end subroutine ncperiodogram_frac_rms_real
!-------------------------------------------------------------------

!-------------------------------------------------------------------
      subroutine periodogram_frac_rms_real(time_series, pw, dim)
! Calculates power spectrum of the time series lc(dim)
! In fractional  rms normalisation
! ***MODIFIED*** from Press et al (1992) DFT definition
        use dyn_lc
        implicit none
        integer, intent(IN)  :: dim
        real   , intent(IN)  :: time_series(dim)
        real   , intent(OUT) :: pw(dim / 2)

        integer              :: j
        real                 :: mean !sum, var
        real   ,allocatable  :: datah(:)

        if (.not. allocated(datah)) allocate(datah(2 * dim))
        ! sum = 0.0

        do j = 1, dim
           datah(2 * j - 1) = time_series(j)
           datah(2 * j)   = 0.0
        end do

        call four1_real(datah, dim, 1)
        mean = datah(1) / dim

        do j = 1, dim / 2
          pw(j) = (datah(2 * j + 1)**2 + datah(2 * j + 2 )**2) * 2. * real(dt) / (float(dim) * mean**2)
        end do

        if (allocated(datah)) deallocate(datah)
        return
      end subroutine periodogram_frac_rms_real
!------------------------------------------------------------------

!------------------------------------------------------------------
      subroutine ncperiodogram_real(ht, st, rc, ic, dim)
! Calculates a cross spectrum between the time series ht(int_len_dim) and st(int_len_dim)
! In absolute  rms normalisation
! Phase is such that +ve lag corresponds to ht lagging st
! ***MODIFIED*** from Press et al (1992) DFT definition, this is S^*(\nu)H(\nu)
        use dyn_lc
        implicit none
        integer, intent(IN)  :: dim
        real   , intent(IN)  :: ht(dim), st(dim)
        real   , intent(OUT) :: rc(dim / 2), ic(dim / 2)
        integer              :: j
        real                 :: meanh, means
        real   , allocatable :: datah(:), datas(:)
        if (.not. allocated(datah)) allocate(datah(2 * dim))
        if (.not. allocated(datas)) allocate(datas(2 * dim))

        do j = 1, dim
           datah(2 * j - 1) = ht(j)
           datah(2 * j)     = 0.0
           datas(2 * j - 1) = st(j)
           datas(2 * j)     = 0.0
        end do
        call four1_real(datah, dim, 1)
        call four1_real(datas, dim, 1)

        meanh = datah(1) / dim
        means = datas(1) / dim

        do j = 1, dim / 2
           rc(j) = datah(2 * j + 1) * datas(2 * j + 1) + datah(2 * j + 2) * datas(2 * j + 2)
           rc(j) = rc(j) * 2.0 * real(dt) / (real(dim) )
           ic(j) = datah(2 * j + 2) * datas(2 * j + 1) - datah(2 * j + 1) * datas(2 * j + 2)
           ic(j) = ic(j) *  2.0 * real(dt) / (real(dim))

        end do
        if (allocated(datah)) deallocate(datah)
        if (allocated(datas)) deallocate(datas)
        return
      end subroutine ncperiodogram_real
!-------------------------------------------------------------------

!-------------------------------------------------------------------
      subroutine periodogram_real(time_series, pw, dim)
! Calculates power spectrum between the time series lc(dim)
! In absolute  rms normalisation
! Phase is such that +ve lag corresponds to ht lagging st
! ***MODIFIED*** from Press et al (1992) DFT definition
        use dyn_lc
        implicit none
        integer, intent(IN)  :: dim
        real   , intent(IN)  :: time_series(dim)
        real   , intent(OUT) :: pw(dim / 2)

        integer              :: j
        real                 :: mean !sum, var
        real   ,allocatable  :: datah(:)

        if (.not. allocated(datah)) allocate(datah(2 * dim))
        ! sum = 0.0

        do j = 1, dim
           ! sum = sum + ht(j)**2
           datah(2 * j - 1) = time_series(j)
           datah(2 * j)   = 0.0
        end do

        call four1_real(datah, dim, 1)
        mean = datah(1) / dim

        do j = 1, dim / 2
           pw(j) = (datah(2 * j + 1)**2 + datah(2 * j + 2 )**2) * 2. * real(dt) / (float(dim))
        end do

!Check the Parcival theorem
!         var = 0.0
!         do j = 0, dim - 1
! !           write(*,*) 2 * j + 1, 2 * j + 2
!            var = var + datah(2 * j + 1)**2 + datah(2 * j + 2 )**2
!            write(111,*) j, datah(2 * j + 1)**2 + datah(2 * j + 2 )**2
!         enddo
!         var = var / dim
!         write(*,*)  'Parcival theorem'
!         write(*,*)  sum, var

!         var = 0.0
!         do j = 1, dim / 2
!            var = var + pw(j)
!         enddo
!         var = (2 * var + datah(1)**2)  / dim
!         write(*,*)  'Parcival theorem'
!         write(*,*)  sum, var

        if (allocated(datah)) deallocate(datah)
        return
      end subroutine periodogram_real
!-------------------------------------------------------------------

!-------------------------------------------------------------------
      subroutine periodogram_leahy_real(ht, pw)
! Calculates power spectrum between the time series ht(int_len_dim)
! In leahy normalisation
! Phase is such that +ve lag corresponds to ht lagging st
! ***MODIFIED*** from Press et al (1992) DFT definition
        use dyn_lc
        implicit none
        real   , intent(IN)  :: ht(int_len_dim)
        real   , intent(OUT) :: pw(int_len_dim / 2)

        integer              :: j
        real                 :: mean
        real   ,allocatable  :: datah(:)

        if (.not. allocated(datah)) allocate(datah(2 * int_len_dim))
        ! sum = 0.0
        do j = 1, int_len_dim
           ! sum = sum + ht(j)**2
           datah(2 * j - 1) = ht(j)
           datah(2 * j)   = 0.0
        end do
        call four1_real(datah, int_len_dim, 1)
        mean = datah(1) / int_len_dim
        do j = 1, int_len_dim / 2
           pw(j) = (datah(2 * j + 1)**2 + datah(2 * j + 2 )**2) * 2.0 / datah(1)
        end do

        if (allocated(datah)) deallocate(datah)
        return
      end subroutine periodogram_leahy_real
!-----------------------------------------------------------------

!-----------------------------------------------------------------
      SUBROUTINE four1_real(data,nn,isign)
      INTEGER isign,nn
      REAL data(2*nn)
      INTEGER i,istep,j,m,mmax,n
      REAL tempi,tempr
      DOUBLE PRECISION theta,wi,wpi,wpr,wr,wtemp
      n=2*nn
      j=1
      ! write(*,*) 'ciao ciao '

      ! do i = 1, nn
      !    write(*,*) i, data(2 * i - 1), data(2 * i)
      ! enddo
      ! write(*,*) 'ciao ciao '

      do 11 i=1,n,2
        if(j.gt.i)then
          tempr=data(j)
          tempi=data(j+1)
          data(j)=data(i)
          data(j+1)=data(i+1)
          data(i)=tempr
          data(i+1)=tempi
        endif
        m=n/2
1       if ((m.ge.2).and.(j.gt.m)) then
          j=j-m
          m=m/2
        goto 1
        endif
        j=j+m
11    continue
      mmax=2
2     if (n.gt.mmax) then
        istep=2*mmax
        theta=6.28318530717959d0/(isign*mmax)
        wpr=-2.d0*sin(0.5d0*theta)**2
        wpi=sin(theta)
        wr=1.d0
        wi=0.d0
        do 13 m=1,mmax,2
          do 12 i=m,n,istep
            j=i+mmax
            tempr=sngl(wr)*data(j)-sngl(wi)*data(j+1)
            tempi=sngl(wr)*data(j+1)+sngl(wi)*data(j)
            data(j)=data(i)-tempr
            data(j+1)=data(i+1)-tempi
            data(i)=data(i)+tempr
            data(i+1)=data(i+1)+tempi
12        continue
          wtemp=wr
          wr=wr*wpr-wi*wpi+wr
          wi=wi*wpr+wtemp*wpi+wi
13      continue
        mmax=istep
      goto 2
      endif
      return
      end
!-----------------------------------------------------------------------

!---------------------------------------------------------------------!
subroutine cross_FT(lc1, lc2, rc, ic, NN, dt)
! This subroutine calculates the cross-spectrum between lc1 and lc2
! lc2 is the complex cojugate light curve (reference light curve)

! re1, im1, re2, im2 are the real and imaginary part to calculare the
! Fourier transform
  implicit none
  integer         , intent(IN)    :: NN
  double precision, intent(IN)    :: lc1(NN), lc2(NN), dt
  double precision, intent(OUT)   :: rc(NN / 2), ic(NN / 2)

  integer                         :: i
  double precision, allocatable   :: re1(:), im1(:), re2(:), im2(:)

  allocate (re1(NN / 2))
  allocate (im1(NN / 2))
  allocate (re2(NN / 2))
  allocate (im2(NN / 2))

  call FT_not_fast(lc1, re1, im1, NN)
  call FT_not_fast(lc2, re2, im2, NN)

  do i = 1, NN / 2
     rc(i) = (re1(i) * re2(i) + im1(i) * im2(i)) *  2 * dt / (real(NN))
     ic(i) = (im1(i) * re2(i) - re1(i) * im2(i)) *  2 * dt / (real(NN))
  enddo

   end subroutine Cross_FT
!---------------------------------------------------------------------!

!---------------------------------------------------------------------!
subroutine power_FT(lc1, pw, NN, dt)
! This subroutine calculates the power-spectrum of lc1
! re1, im1 are the real and imaginary part to calculare the Fourier transform
  implicit none
  integer         , intent(IN)    :: NN
  double precision, intent(IN)    :: lc1(NN), dt
  double precision, intent(OUT)   :: pw(NN / 2)

  integer                         :: i
  double precision, allocatable   :: re1(:), im1(:)

  allocate (re1(NN / 2))
  allocate (im1(NN / 2))

  call FT_not_fast(lc1, re1, im1, NN)

  do i = 1, NN / 2
     pw(i) = (re1(i) * re1(i) + im1(i) * im1(i) ) *  2 * dt / (real(NN))
  enddo

end subroutine Power_FT
!---------------------------------------------------------------------!

!---------------------------------------------------------------------!
subroutine FT_not_fast(time_series, re, im, NN)
! This subroutine calculates the Fourier transfor of a series time_series with NN data points
! re and im are respectively the real and the imaginary part of the FT
! re and im don't store the average of the light curve, so they have NN/2
! The first frequency is nu = 1/(NN*dt) the last is the Nyquist frequency nuNy = 1/(2*dt)
  implicit none
  integer         , intent(IN)    :: NN
  double precision, intent(IN)    :: time_series(NN)
  double precision, intent(INOUT) :: re(NN / 2), im(NN / 2)

  integer                         :: n, k
  double precision                :: arg
  double precision, parameter     :: pi = acos(-1.0)

  do n = 1, NN / 2
     re(n) = 0.0
     im(n) = 0.0

     do k = 1, NN
        arg = 2.0 * pi * real(k * n) / real(NN)
        re(n) = re(n) + time_series(k) * cos(arg)
        im(n) = im(n) + time_series(k) * sin(arg)
     enddo
     re(n) = re(n) / real(NN)
     im(n) = im(n) / real(NN)
  enddo

end subroutine FT_not_fast
!---------------------------------------------------------------------!

!-----------------------------------------------------------------------
subroutine SFT(at,nnmax,nn,Af)
  implicit none
  integer nnmax,nn,j,k
  real at(nnmax)
  complex Af(nnmax/2)
  real pi,arg
  pi = acos(-1.0)
  do j = 1,nn/2
     Af(j) = 0.0
     do k = 1,nn
        arg   = 2.0 * pi * real( j * k ) / real(nn)
        Af(j) = Af(j) + at(k) * complex( cos(arg) , sin(arg) )
     end do
     Af(j) = Af(j) / real(nn)
  end do
  return
end subroutine SFT
!-----------------------------------------------------------------------