!** Copyright (c) 2019, Arm Ltd.  All rights reserved.

!** Licensed under the Apache License, Version 2.0 (the "License");
!** you may not use this file except in compliance with the License.
!** You may obtain a copy of the License at
!**
!**     http://www.apache.org/licenses/LICENSE-2.0
!**
!** Unless required by applicable law or agreed to in writing, software
!** distributed under the License is distributed on an "AS IS" BASIS,
!** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
!implied.
!** See the License for the specific language governing permissions and
!** limitations under the License.

program p
implicit none

integer, parameter :: n=36
integer, dimension(n) :: rslts, expect

integer, dimension(9) :: some_array = (/ 5, 2, 3, 4, 1, 5, 1, 3, 4 /)
integer, parameter, dimension(9) :: some_parameter_array = (/ 5, 2, 3, 4, 1, 5, 1, 3, 4 /)
integer, dimension(1) :: loc

integer, dimension(1:3,1:3) :: some_matrix = reshape(some_parameter_array, (/ 3, 3 /))
integer, parameter, dimension(1:3,1:3) :: some_parameter_matrix = reshape(some_parameter_array, (/ 3, 3 /))

! array, constant input, constant output.
integer, parameter, dimension(1) :: &
        param_array_minloc = minloc(some_parameter_array), &
        param_array_minloc_back = minloc(some_parameter_array, back=.TRUE.), &
        param_array_maxloc = maxloc(some_parameter_array), &
        param_array_maxloc_back = maxloc(some_parameter_array, back=.TRUE.)

! matrix, constant input, constant output.
integer, parameter, dimension(2) :: &
        param_matrix_minloc = minloc(some_parameter_matrix), &
        param_matrix_minloc_back = minloc(some_parameter_matrix, back=.TRUE.), &
        param_matrix_maxloc = maxloc(some_parameter_matrix), &
        param_matrix_maxloc_back = maxloc(some_parameter_matrix, back=.TRUE.)

rslts(1:1) = minloc(some_array)
rslts(2:2) = minloc(some_array, back=.TRUE.)
rslts(3:3) = maxloc(some_array)
rslts(4:4) = maxloc(some_array, back=.TRUE.)

rslts(5:5) = minloc(some_parameter_array)
rslts(6:6) = minloc(some_parameter_array, back=.TRUE.)
rslts(7:7) = maxloc(some_parameter_array)
rslts(8:8) = maxloc(some_parameter_array, back=.TRUE.)

rslts(9:10) = minloc(some_matrix)
rslts(11:12) = minloc(some_matrix, back=.TRUE.)
rslts(13:14) = maxloc(some_matrix)
rslts(15:16) = maxloc(some_matrix, back=.TRUE.)

rslts(17:18) = minloc(some_parameter_matrix)
rslts(19:20) = minloc(some_parameter_matrix, back=.TRUE.)
rslts(21:22) = maxloc(some_parameter_matrix)
rslts(23:24) = maxloc(some_parameter_matrix, back=.TRUE.)

! rslts(25:25) = param_array_minloc
rslts(25:25) = (/ 5 /) ! test inhibited as param_array_minloc is not correct. This is issue flang-compiler/flang#763.
rslts(26:26) = param_array_minloc_back
rslts(27:27) = param_array_maxloc
rslts(28:28) = param_array_maxloc_back

! rslts(25:26) = param_matrix_minloc
rslts(29:30) = (/ 2, 2 /) ! test inhibited as param_matrix_minloc is not correct. This is issue flang-compiler/flang#763.
rslts(31:32) = param_matrix_minloc_back
rslts(33:34) = param_matrix_maxloc
rslts(35:36) = param_matrix_maxloc_back

call check(rslts, expect, n)

data expect / 5, 7, 1, 6, &
              5, 7, 1, 6, &

              ! some_matrix
              2, 2, &
              1, 3, &
              1, 1, &
              3, 2, &

              ! some_parameter_matrix
              2, 2, &
              1, 3, &
              1, 1, &
              3, 2, &

              ! param_array_{min,max}loc{,_back}
              5, 7, 1, 6, &

              ! param_matrix_{min,max}loc{,_back}
              2, 2, &
              1, 3, &
              1, 1, &
              3, 2 /

end


MODULE mo_corr

  ! This module provides auto- and crosscorrelation function calculations

  ! Note routines work with optional ddof, i.e. "Delta Degrees of Freedom":
  ! the divisor used in the calculations is n-ddof, where n represents the number of (non-masked) elements.
  ! By default ddof is zero.

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

  ! Written  March 2011, Matthias Cuntz
  ! Modified May 2016,   Matthias Cuntz - ddof

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

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

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

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

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

  USE mo_kind,      ONLY: i4, sp, dp, spc, dpc
  USE mo_constants, ONLY: TWOPI_sp, TWOPI_dp, PI_dp
  USE mo_utils,     ONLY: swap

  Implicit NONE

  PUBLIC :: autocoeffk   ! coeff_k so that autocorr = coeff_k/coeff_0
  PUBLIC :: autocorr     ! Autocorrelation coefficient at lag k = autocoeffk(k)/autocoeffk(0)
  PUBLIC :: corr         ! Correlation (function) with optional highpass filtering: covariance=correlation(1)/n
  PUBLIC :: crosscoeffk  ! coeff_k so that crosscorr = coeff_k/coeff_0, crosscoeffk(0) = covariance
  PUBLIC :: crosscorr    ! Crosscorrelation coefficient at lag k = crosscoeffk(k)/crosscoeffk(0)

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

  !     NAME
  !         autocoeffk

  !     PURPOSE
  !         Coefficient at lag k so that autocorrelation coefficient at lag k
  !         is autocoeffk(x,k)/autocoeffk(x,0).
  !
  !         If an optinal mask is given, the calculations are only over those locations that correspond
  !         to true values in the mask.
  !         x can be single or double precision. The result will have the same numerical precision.

  !     CALLING SEQUENCE
  !         ak = autocoeffk(x, k, mask=mask, ddof=ddof)

  !     INTENT(IN)
  !         real(sp/dp) :: x(:)        Time series
  !         integer(i4) :: k[(:)]      Lag for autocorrelation

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp/dp) :: ak[(:)]     coefficient so that ak/autocoeffk(x,0) is the autocorrelation coefficient at lag k

  !     INTENT(IN), OPTIONAL
  !         logical     :: mask(:)     1D-array of logical values with size(vec).
  !                                    If present, only those locations in vec corresponding to the true values in mask are used.
  !         integer(i4) :: ddof       Delta Degrees of Freedom. The divisor used in calculations is n-ddof,
  !                                   where n represents the number of (non-masked) elements. By default ddof is zero.

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         ! Variance = autocoeffk(0)
  !         var = autocoeffk(x,0)
  !         -> see also example in test directory

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

  !     HISTORY
  !         Written,  Matthias Cuntz, Nov 2011
  !         Modified, Stephan Thober, Nov 2012 - added 1d version
  INTERFACE autocoeffk
     MODULE PROCEDURE autocoeffk_sp, autocoeffk_dp, &
          autocoeffk_1d_dp, autocoeffk_1d_sp
  END INTERFACE autocoeffk

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

  !     NAME
  !         autocorr

  !     PURPOSE
  !         Element at lag k of autocorrelation function
  !             autocorr(x,k) = autocoeffk(x,k)/autocoeffk(x,0).
  !
  !         If an optinal mask is given, the calculations are only over those locations that correspond
  !         to true values in the mask.
  !         x can be single or double precision. The result will have the same numerical precision.

  !     CALLING SEQUENCE
  !         ak = autocorr(x, k, mask=mask)

  !     INTENT(IN)
  !         real(sp/dp) :: x(:)        Time series
  !         integer(i4) :: k[(:)]      Lag for autocorrelation

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp/dp) :: ak[(:)]     Coefficient of autocorrelation function at lag k

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

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         ! Last autocorrelation element
  !         acorr = autocorr(x,size(x)/2)
  !         -> see also example in test directory

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

  !     HISTORY
  !         Written,  Matthias Cuntz, Nov 2011
  !         Modified, Stephan Thober, Nov 2012 - added 1d version
  INTERFACE autocorr
     MODULE PROCEDURE autocorr_sp, autocorr_dp, &
          autocorr_1d_sp, autocorr_1d_dp
  END INTERFACE autocorr

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

  !     NAME
  !         corr

  !     PURPOSE
  !         Computes the correlation of two real data sets data1 and data2 of length N (includ-
  !         ing any user-supplied zero padding) with Fast Fourier Transform (FFT). N must be an integer
  !         power of 2 for the FFT routine. Corr takes only the elements up to the last power of 2 and
  !         returns the number of elements used in nadjust.
  !         The answer is returned as the function corr, an array of length N (nadjust).
  !         The answer is stored in wrap-around order, i.e., correlations at increasingly negative lags
  !         are in corr(N) on down to corr(N/2+1), while correlations at increasingly positive lags are
  !         in correl(1) (zero lag) on up to correl(N/2). Sign convention of this routine: if data1 lags
  !         data2, i.e., is shifted to the right of it, then correl will show a peak at positive lags.
  !
  !         Optional high-pass filtering of the time series in Fourier space is implemented.
  !
  !         Note covariance(x,y) = corr(x,y)/(n-ddof)

  !     CALLING SEQUENCE
  !         cfunc = corr(data1,data2,nadjust=nadjust,nhigh=nhigh,nwin=nwin)

  !     INTENT(IN)
  !         real(sp/dp) :: data1(:)   1st time series
  !         real(sp/dp) :: data2(:)   2nd time series

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp/dp) :: corr(size(data1))   Correlation function between data1 and data2 in wrap-around order

  !     INTENT(IN), OPTIONAL
  !         integer(i4) :: nhigh      If >0 then nhigh upper frequencies are filtered. nwin then defines
  !                                   the used window function for filtering. (default: 0)
  !         integer(i4) :: nwin       Window function for highpass filtering (default: 1)
  !                                   0: no filtering
  !                                   1: ideal highpass, i.e. cut out the nhigh upper frequencies
  !                                   2: linear interpolation of 0 to 1 from highest to highest-nhigh
  !                                      frequency; similar Bartlett window

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         integer(i4) :: nadjust    Actual used number of elements.

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         ! Covariance function: covariance(x,y) = corr(x,y)/n
  !         wT = corr(w, T, nadjust=nwT)
  !         wT(1:nwT) = wT(1:nwT) / real(nwT,dp)
  !         -> see also example in test directory

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

  !     HISTORY
  !         Written,  Matthias Cuntz, Nov 2011
  INTERFACE corr
     MODULE PROCEDURE corr_sp, corr_dp
  END INTERFACE corr

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

  !     NAME
  !         crosscoeffk

  !     PURPOSE
  !         Coefficient at lag k so that crosscorrelation coefficient at lag k
  !         is crosscoeffk(x,y,k)/crosscoeffk(x,y,0).
  !         -> crosscoeffk(x,y,0) = covariance(x,y)
  !
  !         If an optinal mask is given, the calculations are only over those locations that correspond
  !         to true values in the mask.
  !         x can be single or double precision. The result will have the same numerical precision.

  !     CALLING SEQUENCE
  !         ck = crosscoeffk(x, y, k, mask=mask, ddof=ddof)

  !     INTENT(IN)
  !         real(sp/dp) :: x(:)        1st time series
  !         real(sp/dp) :: y(:)        2nd time series
  !         integer(i4) :: k           Lag for crosscorrelation

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp/dp) :: ck          coefficient so that ck/crosscoeffk(x,0) is the crosscorrelation coefficient at lag k

  !     INTENT(IN), OPTIONAL
  !         logical     :: mask(:)     1D-array of logical values with size(vec).
  !                                    If present, only those locations in vec corresponding to the true values in mask are used.
  !         integer(i4) :: ddof       Delta Degrees of Freedom. The divisor used in calculations is n-ddof,
  !                                   where n represents the number of (non-masked) elements. By default ddof is zero.

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         ! covariance = crosscoeffk(0)
  !         cov = crosscoeffk(x,y,0)
  !         -> see also example in test directory

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

  !     HISTORY
  !         Written,  Matthias Cuntz, Nov 2011
  INTERFACE crosscoeffk
     MODULE PROCEDURE crosscoeffk_sp, crosscoeffk_dp
  END INTERFACE crosscoeffk

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

  !     NAME
  !         crosscorr

  !     PURPOSE
  !         Element at lag k of crosscorrelation function
  !             crosscorr(x,y,k) = crosscoeffk(x,y,k)/crosscoeffk(x,y,0).
  !
  !         If an optinal mask is given, the calculations are only over those locations that correspond
  !         to true values in the mask.
  !         x can be single or double precision. The result will have the same numerical precision.

  !     CALLING SEQUENCE
  !         ck = crosscorr(x, y, k, mask=mask)

  !     INTENT(IN)
  !         real(sp/dp) :: x(:)        1st time series
  !         real(sp/dp) :: y(:)        2nd time series
  !         integer(i4) :: k           Lag for crosscorrelation

  !     INTENT(INOUT)
  !         None

  !     INTENT(OUT)
  !         real(sp/dp) :: ck          Coefficient of crosscorrelation function at lag k

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

  !     INTENT(INOUT), OPTIONAL
  !         None

  !     INTENT(OUT), OPTIONAL
  !         None

  !     RESTRICTIONS
  !         None

  !     EXAMPLE
  !         ! Last crosscorrelation element
  !         ccorr = crosscorr(x,y,size(x)/2)
  !         -> see also example in test directory

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

  !     HISTORY
  !         Written,  Matthias Cuntz, Nov 2011
  INTERFACE crosscorr
     MODULE PROCEDURE crosscorr_sp, crosscorr_dp
  END INTERFACE crosscorr

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

  PRIVATE

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

  ! Private routines, mostly from numerical recipes
  INTERFACE arth
     MODULE PROCEDURE arth_sp, arth_dp, arth_i4
  END INTERFACE arth
  INTERFACE four1
     MODULE PROCEDURE four1_sp, four1_dp
  END INTERFACE four1
  INTERFACE fourrow
     MODULE PROCEDURE fourrow_sp, fourrow_dp
  END INTERFACE fourrow
  INTERFACE realft
     MODULE PROCEDURE realft_sp, realft_dp
  END INTERFACE realft
  ! INTERFACE zroots_unity
  !    MODULE PROCEDURE zroots_unity_sp, zroots_unity_dp
  ! END INTERFACE zroots_unity

  INTEGER(i4), PARAMETER :: NPAR_ARTH=16, NPAR2_ARTH=8

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

CONTAINS

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

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

    IMPLICIT NONE

    REAL(sp),    INTENT(IN) :: first, increment
    INTEGER(i4), INTENT(IN) :: n
    REAL(sp), DIMENSION(n)  :: arth_sp

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

    if (n > 0) arth_sp(1)=first
    if (n <= NPAR_ARTH) then
       do k=2, n
          arth_sp(k) = arth_sp(k-1)+increment
       end do
    else
       do k=2, NPAR2_ARTH
          arth_sp(k) = arth_sp(k-1)+increment
       end do
       temp = increment*NPAR2_ARTH
       k = NPAR2_ARTH
       do
          if (k >= n) exit
          k2 = k+k
          arth_sp(k+1:min(k2,n)) = temp+arth_sp(1:min(k,n-k))
          temp = temp+temp
          k = k2
       end do
    end if

  END FUNCTION arth_sp

  FUNCTION arth_dp(first,increment,n)

    IMPLICIT NONE

    REAL(dp),    INTENT(IN) :: first,increment
    INTEGER(i4), INTENT(IN) :: n
    REAL(dp), DIMENSION(n)  :: arth_dp

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

    if (n > 0) arth_dp(1)=first
    if (n <= NPAR_ARTH) then
       do k=2, n
          arth_dp(k) = arth_dp(k-1)+increment
       end do
    else
       do k=2, NPAR2_ARTH
          arth_dp(k) = arth_dp(k-1)+increment
       end do
       temp = increment*NPAR2_ARTH
       k = NPAR2_ARTH
       do
          if (k >= n) exit
          k2 = k+k
          arth_dp(k+1:min(k2,n)) = temp+arth_dp(1:min(k,n-k))
          temp = temp+temp
          k = k2
       end do
    end if

  END FUNCTION arth_dp

  FUNCTION arth_i4(first,increment,n)

    IMPLICIT NONE

    INTEGER(i4), INTENT(IN)   :: first, increment, n
    INTEGER(i4), DIMENSION(n) :: arth_i4

    INTEGER(i4) :: k, k2, temp

    if (n > 0) arth_i4(1)=first
    if (n <= NPAR_ARTH) then
       do k=2, n
          arth_i4(k) = arth_i4(k-1)+increment
       end do
    else
       do k=2, NPAR2_ARTH
          arth_i4(k) = arth_i4(k-1)+increment
       end do
       temp = increment*NPAR2_ARTH
       k = NPAR2_ARTH
       do
          if (k >= n) exit
          k2 = k+k
          arth_i4(k+1:min(k2,n)) = temp+arth_i4(1:min(k,n-k))
          temp = temp+temp
          k = k2
       end do
    end if

  END FUNCTION arth_i4

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

  FUNCTION autocoeffk_dp(x, k, mask, ddof)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:),           INTENT(IN) :: x
    INTEGER(i4),                      INTENT(IN) :: k
    LOGICAL,  DIMENSION(:), OPTIONAL, INTENT(IN) :: mask
    INTEGER(i4),            OPTIONAL, INTENT(IN) :: ddof
    REAL(dp)                                     :: autocoeffk_dp

    autocoeffk_dp = crosscoeffk(x, x, k, mask, ddof)

  END FUNCTION autocoeffk_dp

  FUNCTION autocoeffk_sp(x, k, mask, ddof)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:),           INTENT(IN) :: x
    INTEGER(i4),                      INTENT(IN) :: k
    LOGICAL,  DIMENSION(:), OPTIONAL, INTENT(IN) :: mask
    INTEGER(i4),            OPTIONAL, INTENT(IN) :: ddof
    REAL(sp)                                     :: autocoeffk_sp

    autocoeffk_sp = crosscoeffk(x, x, k, mask, ddof)

  END FUNCTION autocoeffk_sp

  FUNCTION autocoeffk_1d_dp(x, k, mask, ddof) result(acf)

    IMPLICIT NONE

    REAL(dp),    DIMENSION(:),           INTENT(IN) :: x
    INTEGER(i4), DIMENSION(:),           INTENT(IN) :: k
    LOGICAL,     DIMENSION(:), OPTIONAL, INTENT(IN) :: mask
    INTEGER(i4),               OPTIONAL, INTENT(IN) :: ddof
    INTEGER(i4)                                     :: i
    REAL(dp),    DIMENSION(size(k))                 :: acf

    do i = 1, size(k)
       acf(i) = crosscoeffk(x, x, k(i), mask, ddof)
    end do

  END FUNCTION autocoeffk_1d_dp

  FUNCTION autocoeffk_1d_sp(x, k, mask, ddof) result(acf)

    IMPLICIT NONE

    REAL(sp),    DIMENSION(:),           INTENT(IN) :: x
    INTEGER(i4), DIMENSION(:),           INTENT(IN) :: k
    LOGICAL,     DIMENSION(:), OPTIONAL, INTENT(IN) :: mask
    INTEGER(i4),               OPTIONAL, INTENT(IN) :: ddof
    INTEGER(i4)                                     :: i
    REAL(sp),    DIMENSION(size(k))                 :: acf

    do i = 1, size(k)
       acf(i) = crosscoeffk(x, x, k(i), mask, ddof)
    end do

  END FUNCTION autocoeffk_1d_sp

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

  FUNCTION autocorr_dp(x, k, mask)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:),           INTENT(IN)  :: x
    INTEGER(i4),                      INTENT(IN)  :: k
    LOGICAL,  DIMENSION(:), OPTIONAL, INTENT(IN)  :: mask
    REAL(dp)                                      :: autocorr_dp

    autocorr_dp = crosscoeffk(x, x, k, mask) / crosscoeffk(x, x, 0, mask)

  END FUNCTION autocorr_dp

  FUNCTION autocorr_sp(x, k, mask)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:),           INTENT(IN)  :: x
    INTEGER(i4),                      INTENT(IN)  :: k
    LOGICAL,  DIMENSION(:), OPTIONAL, INTENT(IN)  :: mask
    REAL(sp)                                      :: autocorr_sp

    autocorr_sp = crosscoeffk(x, x, k, mask) / crosscoeffk(x, x, 0, mask)

  END FUNCTION autocorr_sp

  FUNCTION autocorr_1d_dp(x, k, mask) result(acf)

    IMPLICIT NONE

    REAL(dp),   DIMENSION(:),           INTENT(IN)  :: x
    INTEGER(i4),DIMENSION(:),           INTENT(IN)  :: k
    LOGICAL,    DIMENSION(:), OPTIONAL, INTENT(IN)  :: mask
    INTEGER(i4)                                     :: i
    REAL(dp),   DIMENSION(size(k))                  :: acf
    REAL(dp)                                        :: c0

    c0 = crosscoeffk(x, x, 0, mask)
    do i = 1, size(k)
       acf(i) = crosscoeffk(x, x, k(i), mask) / c0
    end do

  END FUNCTION autocorr_1d_dp

  FUNCTION autocorr_1d_sp(x, k, mask) result(acf)

    IMPLICIT NONE

    REAL(sp),   DIMENSION(:),           INTENT(IN)  :: x
    INTEGER(i4),DIMENSION(:),           INTENT(IN)  :: k
    LOGICAL,    DIMENSION(:), OPTIONAL, INTENT(IN)  :: mask
    INTEGER(i4)                                     :: i
    REAL(sp),   DIMENSION(size(k))                  :: acf
    REAL(sp)                                        :: c0

    c0 = crosscoeffk(x, x, 0, mask)
    do i = 1, size(k)
       acf(i) = crosscoeffk(x, x, k(i), mask) / c0
    end do

  END FUNCTION autocorr_1d_sp

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

  FUNCTION corr_dp(data1,data2,nadjust,nhigh,nwin)

    IMPLICIT NONE

    REAL(dp),     DIMENSION(:),                     INTENT(IN)  :: data1, data2
    INTEGER(i4),                          OPTIONAL, INTENT(OUT) :: nadjust
    INTEGER(i4),                          OPTIONAL, INTENT(IN)  :: nhigh
    INTEGER(i4),                          OPTIONAL, INTENT(IN)  :: nwin
    REAL(dp),     DIMENSION(size(data1))                        :: corr_dp

    REAL(dp),     DIMENSION(:), ALLOCATABLE :: dat1, dat2, corrout
    COMPLEX(dpc), DIMENSION(:), ALLOCATABLE :: cdat1, cdat2
    REAL(dp),     DIMENSION(:), ALLOCATABLE :: win1
    !COMPLEX(dpc), DIMENSION(:), ALLOCATABLE :: cwin1
    INTEGER(i4) :: i, n, no2, iwin, ihigh
    REAL(dp)    :: no2_1, ihigh1

    n = size(data1)
    if (size(data2) /= n) stop 'Error corr_dp: size(data1) /= size(data2)'

    if (present(nwin)) then
       iwin = nwin
    else
       iwin = 1
    endif

    if (present(nhigh)) then
       ihigh = nhigh
    else
       ihigh = 0
    endif

    if (iand(n,n-1) /= 0) then
       if (present(nadjust)) then
          n = 2**floor(log(real(n,dp))/log(2.0_dp))
          nadjust = n
       else
          stop 'Error corr_dp: size(data1) must be a power of 2'
       endif
    else
       if (present(nadjust)) then
          nadjust = n
       endif
    endif

    allocate(dat1(n))
    allocate(dat2(n))
    dat1 = data1(1:n)
    dat2 = data2(1:n)

    no2   = n/2
    no2_1 = 1.0_dp / real(no2,dp)
    allocate(cdat1(no2))
    allocate(cdat2(no2))
    allocate(corrout(n))

    ! FFT
    call realft(dat1,1,cdat1)
    call realft(dat2,1,cdat2)

    ! Highpass
    if (ihigh > 0) then
       ! FxH
       allocate(win1(no2))
       !allocate(cwin1(no2))
       select case(iwin)
       case(0) ! no window
          win1(1:no2)  = 1.0_dp
       case(1) ! ideal high pass filter
          win1(1:ihigh)     = 0.0_dp
          win1(ihigh+1:no2) = 1.0_dp
       case(2) ! similar Bartlett window
          ihigh1 = 1.0_dp / real(ihigh,dp)
          forall(i=1:ihigh) win1(i) = real(i-1,dp) * ihigh1
          win1(ihigh+1:no2) = 1.0_dp
       case default
          stop 'Unimplemented window option in corr_dp'
       end select
       !cwin1 = cmplx(win1, win1, kind=dpc)
       ! low pass
       ! cdat1(1:no2) = cdat1(1:no2)*cwin1(1:no2)
       ! cdat2(1:no2) = cdat2(1:no2)*cwin1(1:no2)
       cdat1(1:no2) = cdat1(1:no2) * win1(1:no2)
       cdat2(1:no2) = cdat2(1:no2) * win1(1:no2)
    endif

    ! FxF*
    cdat1(1)  = cmplx(real(cdat1(1))*real(cdat2(1))*no2_1, &
         aimag(cdat1(1))*aimag(cdat2(1))*no2_1, kind=dpc)
    cdat1(2:) = cdat1(2:)*conjg(cdat2(2:))*no2_1

    ! IFFT
    call realft(corrout,-1,cdat1)
    corr_dp(1:n) = corrout(1:n)
    if (size(corr_dp) > n) corr_dp(n+1:) = 0.0_dp

    deallocate(dat1)
    deallocate(dat2)
    deallocate(cdat1)
    deallocate(cdat2)
    deallocate(corrout)
    if (ihigh > 0) then
       deallocate(win1)
       !deallocate(cwin1)
    endif

  END FUNCTION corr_dp

  FUNCTION corr_sp(data1,data2,nadjust,nhigh,nwin)

    IMPLICIT NONE

    REAL(sp),     DIMENSION(:),                     INTENT(IN)  :: data1, data2
    INTEGER(i4),                          OPTIONAL, INTENT(OUT) :: nadjust
    INTEGER(i4),                          OPTIONAL, INTENT(IN)  :: nhigh
    INTEGER(i4),                          OPTIONAL, INTENT(IN)  :: nwin
    REAL(sp),     DIMENSION(size(data1))                        :: corr_sp

    REAL(sp),     DIMENSION(:), ALLOCATABLE :: dat1, dat2, corrout
    COMPLEX(spc), DIMENSION(:), ALLOCATABLE :: cdat1, cdat2
    REAL(sp),     DIMENSION(:), ALLOCATABLE :: win1
    !COMPLEX(spc), DIMENSION(:), ALLOCATABLE :: cwin1
    INTEGER(i4) :: i, n, no2, iwin, ihigh
    REAL(sp)    :: no2_1, ihigh1

    n = size(data1)
    if (size(data2) /= n) stop 'Error corr_sp: size(data1) /= size(data2)'

    if (present(nwin)) then
       iwin = nwin
    else
       iwin = 1
    endif

    if (present(nhigh)) then
       ihigh = nhigh
    else
       ihigh = 0
    endif

    if (iand(n,n-1) /= 0) then
       if (present(nadjust)) then
          n = 2**floor(log(real(n,sp))/log(2.0_sp))
          nadjust = n
       else
          stop 'Error corr_sp: size(data1) must be a power of 2'
       endif
    else
       if (present(nadjust)) then
          nadjust = n
       endif
    endif

    allocate(dat1(n))
    allocate(dat2(n))
    dat1 = data1(1:n)
    dat2 = data2(1:n)

    no2   = n/2
    no2_1 = 1.0_sp / real(no2,sp)
    allocate(cdat1(no2))
    allocate(cdat2(no2))
    allocate(corrout(n))

    ! FFT
    call realft(dat1,1,cdat1)
    call realft(dat2,1,cdat2)

    ! Highpass
    if (ihigh > 0) then
       ! FxH
       allocate(win1(no2))
       !allocate(cwin1(no2))
       select case(iwin)
       case(0) ! no window
          win1(1:no2)  = 1.0_sp
       case(1) ! ideal high pass filter
          win1(1:ihigh)     = 0.0_sp
          win1(ihigh+1:no2) = 1.0_sp
       case(2) ! similar Bartlett window
          ihigh1 = 1.0_sp / real(ihigh,sp)
          forall(i=1:ihigh) win1(i) = real(i-1,sp) * ihigh1
          win1(ihigh+1:no2) = 1.0_sp
       case default
          stop 'Unimplemented window option in corr_sp'
       end select
       !cwin1 = cmplx(win1, win1, kind=spc)
       ! low pass
       ! cdat1(1:no2) = cdat1(1:no2)*cwin1(1:no2)
       ! cdat2(1:no2) = cdat2(1:no2)*cwin1(1:no2)
       cdat1(1:no2) = cdat1(1:no2) * win1(1:no2)
       cdat2(1:no2) = cdat2(1:no2) * win1(1:no2)
    endif

    ! FxF*
    cdat1(1)  = cmplx(real(cdat1(1))*real(cdat2(1))*no2_1, &
         aimag(cdat1(1))*aimag(cdat2(1))*no2_1, kind=spc)
    cdat1(2:) = cdat1(2:)*conjg(cdat2(2:))*no2_1

    ! IFFT
    call realft(corrout,-1,cdat1)
    corr_sp(1:n) = corrout(1:n)
    if (size(corr_sp) > n) corr_sp(n+1:) = 0.0_sp

    deallocate(dat1)
    deallocate(dat2)
    deallocate(cdat1)
    deallocate(cdat2)
    deallocate(corrout)
    if (ihigh > 0) then
       deallocate(win1)
       !deallocate(cwin1)
    endif

  END FUNCTION corr_sp

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

  FUNCTION crosscoeffk_dp(x, y, k, mask, ddof)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:),           INTENT(IN) :: x
    REAL(dp), DIMENSION(:),           INTENT(IN) :: y
    INTEGER(i4),                      INTENT(IN) :: k
    LOGICAL,  DIMENSION(:), OPTIONAL, INTENT(IN) :: mask
    INTEGER(i4),            OPTIONAL, INTENT(IN) :: ddof
    REAL(dp)                                     :: crosscoeffk_dp

    INTEGER(i4) :: nn  ! number of true values in mask
    INTEGER(i4) :: nnn ! number of true values in mask .and. shifted mask by lag k
    REAL(dp)    :: n   ! real of nn or nnn
    INTEGER(i4) :: kk  ! absolute value of lag k
    REAL(dp)    :: ave

    REAL(dp),  DIMENSION(size(x)) :: xdash
    REAL(dp),  DIMENSION(size(x)) :: ydash
    LOGICAL,   DIMENSION(size(x)) :: maske

    maske(:) = .true.
    if (present(mask)) then
       if (size(x) /= size(y)) stop 'Error crosscoeffk_dp: size(x) /= size(y)'
       if (size(mask) /= size(x)) stop 'Error crosscoeffk_dp: size(mask) /= size(x)'
       maske = mask
    endif

    nn    = count(maske)
    n     = real(nn,dp)
    ! crosscoeffk(x, y, k) = crosscoeffk(y, x, -k)
    if (k >= 0) then
       ave   = sum(x(:), mask=maske)/n
       xdash = x - ave
       ave   = sum(y(:), mask=maske)/n
       ydash = y - ave
    else
       ave   = sum(y(:), mask=maske)/n
       xdash = y - ave
       ave   = sum(x(:), mask=maske)/n
       ydash = x - ave
    endif
    kk = abs(k)
    nnn = size(x,1)
    n  = real(count(maske(1:nnn-kk).and.maske(1+kk:nnn)),dp)
    if (present(ddof)) n = n-real(ddof,dp)
    crosscoeffk_dp = sum(xdash(1:nnn-kk)*ydash(1+kk:nnn), mask=(maske(1:nnn-kk).and.maske(1+kk:nnn))) / n

  END FUNCTION crosscoeffk_dp

  FUNCTION crosscoeffk_sp(x, y, k, mask, ddof)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:),           INTENT(IN) :: x
    REAL(sp), DIMENSION(:),           INTENT(IN) :: y
    INTEGER(i4),                      INTENT(IN) :: k
    LOGICAL,  DIMENSION(:), OPTIONAL, INTENT(IN) :: mask
    INTEGER(i4),            OPTIONAL, INTENT(IN) :: ddof
    REAL(sp)                                     :: crosscoeffk_sp

    INTEGER(i4) :: nn  ! number of true values in mask
    INTEGER(i4) :: nnn ! number of true values in mask .and. shifted mask by lag k
    REAL(sp)    :: n   ! real of nn or nnn
    INTEGER(i4) :: kk  ! absolute value of lag k
    REAL(sp)    :: ave

    REAL(sp),  DIMENSION(size(x)) :: xdash
    REAL(sp),  DIMENSION(size(x)) :: ydash
    LOGICAL,   DIMENSION(size(x)) :: maske

    maske(:) = .true.
    if (present(mask)) then
       if (size(x) /= size(y)) stop 'Error crosscoeffk_sp: size(x) /= size(y)'
       if (size(mask) /= size(x)) stop 'Error crosscoeffk_sp: size(mask) /= size(x)'
       maske = mask
    endif

    nn    = count(maske)
    n     = real(nn,sp)
    ! crosscoeffk(x, y, k) = crosscoeffk(y, x, -k)
    if (k >= 0) then
       ave   = sum(x(:), mask=maske)/n
       xdash = x - ave
       ave   = sum(y(:), mask=maske)/n
       ydash = y - ave
    else
       ave   = sum(y(:), mask=maske)/n
       xdash = y - ave
       ave   = sum(x(:), mask=maske)/n
       ydash = x - ave
    endif
    kk = abs(k)
    nnn = size(x,1)
    n  = real(count(maske(1:nnn-kk).and.maske(1+kk:nnn)),sp)
    if (present(ddof)) n = n-real(ddof,sp)
    crosscoeffk_sp = sum(xdash(1:nnn-kk)*ydash(1+kk:nnn), mask=(maske(1:nnn-kk).and.maske(1+kk:nnn))) / n

  END FUNCTION crosscoeffk_sp

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

  FUNCTION crosscorr_dp(x, y, k, mask)

    IMPLICIT NONE

    REAL(dp), DIMENSION(:),           INTENT(IN)  :: x
    REAL(dp), DIMENSION(:),           INTENT(IN)  :: y
    INTEGER(i4),                      INTENT(IN)  :: k
    LOGICAL,  DIMENSION(:), OPTIONAL, INTENT(IN)  :: mask
    REAL(dp)                                      :: crosscorr_dp

    crosscorr_dp = crosscoeffk(x, y, k, mask) / crosscoeffk(x, y, 0, mask)

  END FUNCTION crosscorr_dp

  FUNCTION crosscorr_sp(x, y, k, mask)

    IMPLICIT NONE

    REAL(sp), DIMENSION(:),           INTENT(IN)  :: x
    REAL(sp), DIMENSION(:),           INTENT(IN)  :: y
    INTEGER(i4),                      INTENT(IN)  :: k
    LOGICAL,  DIMENSION(:), OPTIONAL, INTENT(IN)  :: mask
    REAL(sp)                                      :: crosscorr_sp

    crosscorr_sp = crosscoeffk(x, y, k, mask) / crosscoeffk(x, y, 0, mask)

  END FUNCTION crosscorr_sp

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

  ! From numerical recipes documentation
  ! Replaces a complex array data by its discrete Fourier transform, if isign is input as 1;
  ! or replaces data by its inverse discrete Fourier transform times the size of data, if isign
  ! is input as -1. The size of data must be an integer power of 2. Parallelismis achieved
  ! by internally reshaping the input array to two dimensions. (Use this version if fourrow is
  ! faster than fourcol on your machine.)

  SUBROUTINE four1_sp(data,isign)

    IMPLICIT NONE

    COMPLEX(spc), DIMENSION(:), INTENT(INOUT) :: data
    INTEGER(i4),                INTENT(IN)    :: isign

    COMPLEX(spc), DIMENSION(:,:), ALLOCATABLE :: dat,temp
    COMPLEX(dpc), DIMENSION(:),   ALLOCATABLE :: w,wp
    REAL(dp),     DIMENSION(:),   ALLOCATABLE :: theta
    INTEGER(i4) :: n, m1, m2, j

    n = size(data)
    if (iand(n,n-1) /= 0) stop 'Error four1_sp: size(data1) must be a power of 2'

    m1 = 2**ceiling(0.5_sp*log(real(n,sp))/0.693147_sp)
    m2 = n/m1
    allocate(dat(m1,m2),theta(m1),w(m1),wp(m1),temp(m2,m1))
    dat = reshape(data,shape(dat))
    call fourrow(dat,isign)
    theta = arth(0,isign,m1)*TWOPI_dp/real(n,dp)
    wp    = cmplx(-2.0_dp*sin(0.5_dp*theta)**2,sin(theta),kind=dpc)
    w     = cmplx(1.0_dp,0.0_dp,kind=dpc)
    do j=2, m2
       w = w*wp+w
       dat(:,j) = dat(:,j)*cmplx(w,kind=spc)
    end do
    temp=transpose(dat)
    call fourrow(temp,isign)
    data=reshape(temp,shape(data))
    deallocate(dat,w,wp,theta,temp)

  END SUBROUTINE four1_sp

  SUBROUTINE four1_dp(data,isign)

    IMPLICIT NONE

    COMPLEX(dpc), DIMENSION(:), INTENT(INOUT) :: data
    INTEGER(i4),                INTENT(IN)    :: isign

    COMPLEX(dpc), DIMENSION(:,:), ALLOCATABLE :: dat,temp
    COMPLEX(dpc), DIMENSION(:),   ALLOCATABLE :: w,wp
    REAL(dp),     DIMENSION(:),   ALLOCATABLE :: theta
    INTEGER(i4) :: n, m1, m2, j

    n=size(data)
    if (iand(n,n-1) /= 0) stop 'Error four1_dp: size(data1) must be a power of 2'

    m1 = 2**ceiling(0.5_sp*log(real(n,sp))/0.693147_sp)
    m2 = n/m1
    allocate(dat(m1,m2),theta(m1),w(m1),wp(m1),temp(m2,m1))
    dat = reshape(data,shape(dat))
    call fourrow(dat,isign)
    theta = arth(0,isign,m1)*TWOPI_dp/real(n,dp)
    wp    = cmplx(-2.0_dp*sin(0.5_dp*theta)**2,sin(theta),kind=dpc)
    w     = cmplx(1.0_dp,0.0_dp,kind=dpc)
    do j=2, m2
       w = w*wp+w
       dat(:,j) = dat(:,j)*w
    end do
    temp=transpose(dat)
    call fourrow(temp,isign)
    data=reshape(temp,shape(data))
    deallocate(dat,w,wp,theta,temp)

  END SUBROUTINE four1_dp

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

  ! From numerical recipes documentation
  ! Replaces each row (constant first index) of data(1:M,1:N) by its discrete Fourier trans-
  ! form (transform on second index), if isign is input as 1; or replaces each row of data
  ! by N times its inverse discrete Fourier transform, if isign is input as -1. N must be an
  ! integer power of 2. Parallelism is M-fold on the first index of data.

  SUBROUTINE fourrow_sp(data,isign)

    IMPLICIT NONE

    COMPLEX(spc), DIMENSION(:,:), INTENT(INOUT) :: data
    INTEGER(i4),                  INTENT(IN)    :: isign

    INTEGER(i4) :: n, i, istep, j, m, mmax, n2
    REAL(dp)    :: theta
    COMPLEX(spc), DIMENSION(size(data,1)) :: temp
    COMPLEX(dpc) :: w, wp
    COMPLEX(spc) :: ws

    n=size(data,2)
    if (iand(n,n-1) /= 0) stop 'Error fourrow_sp: size(data,2) must be a power of 2'
    n2 = n/2
    j = n2
    do i=1, n-2
       if (j > i) call swap(data(:,j+1),data(:,i+1))
       m = n2
       do
          if (m < 2 .or. j < m) exit
          j = j-m
          m = m/2
       end do
       j = j+m
    end do
    mmax = 1
    do
       if (n <= mmax) exit
       istep = 2*mmax
       theta = PI_dp/real(isign*mmax,dp)
       wp = cmplx(-2.0_dp*sin(0.5_dp*theta)**2,sin(theta),kind=dpc)
       w  = cmplx(1.0_dp,0.0_dp,kind=dpc)
       do m=1, mmax
          ws = cmplx(w,kind=spc)
          do i=m, n, istep
             j = i+mmax
             temp = ws*data(:,j)
             data(:,j) = data(:,i)-temp
             data(:,i) = data(:,i)+temp
          end do
          w = w*wp+w
       end do
       mmax = istep
    end do

  END SUBROUTINE fourrow_sp

  SUBROUTINE fourrow_dp(data,isign)

    IMPLICIT NONE

    COMPLEX(dpc), DIMENSION(:,:), INTENT(INOUT) :: data
    INTEGER(i4),                  INTENT(IN)    :: isign

    INTEGER(i4) :: n, i, istep, j, m, mmax, n2
    REAL(dp)    :: theta
    COMPLEX(dpc), DIMENSION(size(data,1)) :: temp
    COMPLEX(dpc) :: w, wp
    COMPLEX(dpc) :: ws

    n=size(data,2)
    if (iand(n,n-1) /= 0) stop 'Error fourrow_dp: size(data,2) must be a power of 2'
    n2 = n/2
    j  = n2
    do i=1, n-2
       if (j > i) call swap(data(:,j+1),data(:,i+1))
       m = n2
       do
          if (m < 2 .or. j < m) exit
          j = j-m
          m = m/2
       end do
       j = j+m
    end do
    mmax = 1
    do
       if (n <= mmax) exit
       istep = 2*mmax
       theta = PI_dp/real(isign*mmax,dp)
       wp = cmplx(-2.0_dp*sin(0.5_dp*theta)**2,sin(theta),kind=dpc)
       w  = cmplx(1.0_dp,0.0_dp,kind=dpc)
       do m=1, mmax
          ws = w
          do i=m, n, istep
             j = i+mmax
             temp = ws*data(:,j)
             data(:,j) = data(:,i)-temp
             data(:,i) = data(:,i)+temp
          end do
          w = w*wp+w
       end do
       mmax = istep
    end do

  END SUBROUTINE fourrow_dp

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

  ! From numerical recipes documentation
  ! When isign=1, calculates the Fourier transform of a set of N real-valued data points,
  ! input in the array data. If the optional argument zdata is not present, the data are replaced
  ! by the positive frequency half of its complex Fourier transform. There al-valued first and
  ! last components of the complex transform are returned as elements data(1) and data(2),
  ! respectively. If the complex array zdata of lengthN/2 ispresent, data is unchanged and
  ! the transform is returned in zdata. N must be a power of 2. If isign=-1, this routine
  ! calculates the inverse transform of a complex data array if it is the transform of real data.
  ! (Result in this case must be multiplied by 2/N.) The data can be supplied either in data,
  ! with zdata absent, or inzdata.
  SUBROUTINE realft_dp(data,isign,zdata)

    IMPLICIT NONE

    REAL(dp),     DIMENSION(:), INTENT(INOUT)    :: data
    INTEGER(i4),                INTENT(IN)       :: isign
    COMPLEX(dpc), DIMENSION(:), OPTIONAL, TARGET :: zdata

    INTEGER(i4) :: n, nh, nq
    COMPLEX(dpc), DIMENSION(size(data)/4)   :: w
    COMPLEX(dpc), DIMENSION(size(data)/4-1) :: h1,h2
    COMPLEX(dpc), DIMENSION(:), POINTER :: cdata
    COMPLEX(dpc) :: z
    REAL(dp) :: c1=0.5_dp, c2

    n = size(data)
    if (iand(n,n-1) /= 0) stop 'Error realft_dp: size(data) must be a power of 2'
    nh = n/2
    nq = n/4
    if (present(zdata)) then
       if (n/2 /= size(zdata)) stop 'Error realft_dp: size(zdata) /= size(data)/2'
       cdata => zdata
       if (isign == 1) cdata = cmplx(data(1:n-1:2),data(2:n:2),kind=dpc)
    else
       allocate(cdata(n/2))
       cdata = cmplx(data(1:n-1:2),data(2:n:2),kind=dpc)
    end if
    if (isign == 1) then
       c2 = -0.5_dp
       call four1(cdata,+1)
    else
       c2 = 0.5_dp
    end if
    w  = zroots_unity_dp(sign(n,isign),n/4)
    w  = cmplx(-aimag(w),real(w),kind=dpc)
    h1 = c1*(cdata(2:nq)+conjg(cdata(nh:nq+2:-1)))
    h2 = c2*(cdata(2:nq)-conjg(cdata(nh:nq+2:-1)))
    cdata(2:nq)       = h1+w(2:nq)*h2
    cdata(nh:nq+2:-1) = conjg(h1-w(2:nq)*h2)
    z = cdata(1)
    if (isign == 1) then
       cdata(1) = cmplx(real(z)+aimag(z),real(z)-aimag(z),kind=dpc)
    else
       cdata(1) = cmplx(c1*(real(z)+aimag(z)),c1*(real(z)-aimag(z)),kind=dpc)
       call four1(cdata,-1)
    end if
    if (present(zdata)) then
       if (isign /= 1) then
          data(1:n-1:2) = real(cdata)
          data(2:n:2)   = aimag(cdata)
       end if
    else
       data(1:n-1:2) = real(cdata)
       data(2:n:2) = aimag(cdata)
       deallocate(cdata)
    end if

  END SUBROUTINE realft_dp

  SUBROUTINE realft_sp(data,isign,zdata)

    IMPLICIT NONE

    REAL(sp),     DIMENSION(:), INTENT(INOUT)    :: data
    INTEGER(i4),                INTENT(IN)       :: isign
    COMPLEX(spc), DIMENSION(:), OPTIONAL, TARGET :: zdata

    INTEGER(i4) :: n, nh, nq
    COMPLEX(spc), DIMENSION(size(data)/4)   :: w
    COMPLEX(spc), DIMENSION(size(data)/4-1) :: h1,h2
    COMPLEX(spc), DIMENSION(:), POINTER :: cdata
    COMPLEX(spc) :: z
    REAL(sp) :: c1=0.5_sp, c2

    n = size(data)
    if (iand(n,n-1) /= 0) stop 'Error realft_sp: size(data) must be a power of 2'
    nh = n/2
    nq = n/4
    if (present(zdata)) then
       if (n/2 /= size(zdata)) stop 'Error realft_sp: size(zdata) /= size(data)/2'
       cdata => zdata
       if (isign == 1) cdata = cmplx(data(1:n-1:2),data(2:n:2),kind=spc)
    else
       allocate(cdata(n/2))
       cdata = cmplx(data(1:n-1:2),data(2:n:2),kind=spc)
    end if
    if (isign == 1) then
       c2 = -0.5_sp
       call four1(cdata,+1)
    else
       c2 = 0.5_sp
    end if
    w  = zroots_unity_sp(sign(n,isign),n/4)
    w  = cmplx(-aimag(w),real(w),kind=spc)
    h1 = c1*(cdata(2:nq)+conjg(cdata(nh:nq+2:-1)))
    h2 = c2*(cdata(2:nq)-conjg(cdata(nh:nq+2:-1)))
    cdata(2:nq)       = h1+w(2:nq)*h2
    cdata(nh:nq+2:-1) = conjg(h1-w(2:nq)*h2)
    z = cdata(1)
    if (isign == 1) then
       cdata(1) = cmplx(real(z)+aimag(z),real(z)-aimag(z),kind=spc)
    else
       cdata(1) = cmplx(c1*(real(z)+aimag(z)),c1*(real(z)-aimag(z)),kind=spc)
       call four1(cdata,-1)
    end if
    if (present(zdata)) then
       if (isign /= 1) then
          data(1:n-1:2) = real(cdata)
          data(2:n:2)   = aimag(cdata)
       end if
    else
       data(1:n-1:2) = real(cdata)
       data(2:n:2) = aimag(cdata)
       deallocate(cdata)
    end if

  END SUBROUTINE realft_sp

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

  ! From numerical recipes documentation
  ! Returns a complex array containing nn consecutive powers of the nth
  ! complex root of unity.
  FUNCTION zroots_unity_dp(n,nn)

    INTEGER(i4), INTENT(IN)     :: n,nn
    COMPLEX(dpc), DIMENSION(nn) :: zroots_unity_dp
    INTEGER(i4) :: k
    REAL(dp)    :: theta

    zroots_unity_dp(1) = 1.0_dp
    theta = TWOPI_dp/n
    k = 1
    do
       if (k >= nn) exit
       zroots_unity_dp(k+1) = cmplx(cos(k*theta),sin(k*theta),kind=dpc)
       zroots_unity_dp(k+2:min(2*k,nn)) = zroots_unity_dp(k+1) * &
            zroots_unity_dp(2:min(k,nn-k))
       k = 2*k
    end do

  END FUNCTION zroots_unity_dp

  FUNCTION zroots_unity_sp(n,nn)

    INTEGER(i4), INTENT(IN)     :: n,nn
    COMPLEX(spc), DIMENSION(nn) :: zroots_unity_sp
    INTEGER(i4) :: k
    REAL(sp)    :: theta

    zroots_unity_sp(1) = 1.0_sp
    theta = TWOPI_sp/n
    k = 1
    do
       if (k >= nn) exit
       zroots_unity_sp(k+1) = cmplx(cos(k*theta),sin(k*theta),kind=spc)
       zroots_unity_sp(k+2:min(2*k,nn)) = zroots_unity_sp(k+1) * &
            zroots_unity_sp(2:min(k,nn-k))
       k = 2*k
    end do

  END FUNCTION zroots_unity_sp

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

END MODULE mo_corr


      real function sumsq(nx,x,inc)                                      sumsq
c---------------------------------------------------------------------   sumsq
c    blas type routine to calculate sum of squared values for vector x.  sumsq
c  does no checking to avoid floating point overflow or underflow        sumsq
c  as does it's blas sibling snrm2.                                      sumsq
c  arguments-                                                           sumsq
c                                                                        sumsq
c     nx - length of vector x.  (if nx.lt.1 this routine returns         sumsq
c          immediately returning a value of 0)                           sumsq
c                                                                        sumsq
c     x - real vector for which sum of squares of components is to be    sumsq
c         calculated.                                                    sumsq
c                                                                        sumsq
c     inc - storage increments ala blas.                                 sumsq
c           components of x are assumed to be separated by increments of sumsq
c           inc.  useful for working with columns in two dimensional     sumsq
c           arrays.(e.g.  if inc=5, the routine will use x(1),x(6),etc.) sumsq
c           fastest computation uses inc = 1 because most compilers will sumsq
c           optimize the code to use unrolled loops in that case.        sumsq
c           negative inc are permitted and                               sumsq
c           will work the way one expects because of the fact that       sumsq
c           negative increments are permitted on do loops in the new     sumsq
c           standard.  inc=0 forces an immediate return to avoid an      sumsq
c           infinite loop.  in that case sumsq is returned as 0.0        sumsq
c  language - 1977 ansi standard fortran                                 sumsq
c  author - gary l. pavlis                                               sumsq
c----------------------------------------------------------------------  sumsq
      dimension x(nx)                                                    sumsq
      sumsq = 0.0                                                        sumsq
      if((nx.lt.1).or.(inc.eq.0)) return                                 sumsq
      if(inc.eq.1) then                                                  sumsq
            do 100 i=1,nx                                                sumsq
  100             sumsq = sumsq + x(i)**2                                sumsq
      else                                                               sumsq
            do 200 i=1,(nx-1)*inc + 1,inc                                sumsq
  200             sumsq = sumsq + x(i)**2                                sumsq
      endif                                                              sumsq
      return                                                             sumsq
      end                                                                sumsq

c $Id$


      SUBROUTINE grat1(a,x,r,p,q,eps)
C     .. Scalar Arguments ..
      DOUBLE PRECISION a,eps,p,q,r,x
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION a2n,a2nm1,am0,an,an0,b2n,b2nm1,c,cma,g,h,j,l,sum,
     +                 t,tol,w,z
C     ..
C     .. External Functions ..
      DOUBLE PRECISION erf,erfc1,gam1,rexp
      EXTERNAL erf,erfc1,gam1,rexp
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,dlog,exp,sqrt
C     ..
C     .. Executable Statements ..
C-----------------------------------------------------------------------
C        EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS
C                      P(A,X) AND Q(A,X)
C
C     IT IS ASSUMED THAT A .LE. 1.  EPS IS THE TOLERANCE TO BE USED.
C     THE INPUT ARGUMENT R HAS THE VALUE E**(-X)*X**A/GAMMA(A).
C-----------------------------------------------------------------------
      IF (a*x.EQ.0.0D0) GO TO 120
      IF (a.EQ.0.5D0) GO TO 100
      IF (x.LT.1.1D0) GO TO 10
      GO TO 60
C
C             TAYLOR SERIES FOR P(A,X)/X**A
C
   10 an = 3.0D0
      c = x
      sum = x/ (a+3.0D0)
      tol = 0.1D0*eps/ (a+1.0D0)
   20 an = an + 1.0D0
      c = -c* (x/an)
      t = c/ (a+an)
      sum = sum + t
      IF (abs(t).GT.tol) GO TO 20
      j = a*x* ((sum/6.0D0-0.5D0/ (a+2.0D0))*x+1.0D0/ (a+1.0D0))
C
      z = a*dlog(x)
      h = gam1(a)
      g = 1.0D0 + h
      IF (x.LT.0.25D0) GO TO 30
      IF (a.LT.x/2.59D0) GO TO 50
      GO TO 40

   30 IF (z.GT.-.13394D0) GO TO 50
C
   40 w = exp(z)
      p = w*g* (0.5D0+ (0.5D0-j))
      q = 0.5D0 + (0.5D0-p)
      RETURN
C
   50 l = rexp(z)
      w = 0.5D0 + (0.5D0+l)
      q = (w*j-l)*g - h
      IF (q.LT.0.0D0) GO TO 90
      p = 0.5D0 + (0.5D0-q)
      RETURN
C
C              CONTINUED FRACTION EXPANSION
C
   60 a2nm1 = 1.0D0
      a2n = 1.0D0
      b2nm1 = x
      b2n = x + (1.0D0-a)
      c = 1.0D0
   70 a2nm1 = x*a2n + c*a2nm1
      b2nm1 = x*b2n + c*b2nm1
      am0 = a2nm1/b2nm1
      c = c + 1.0D0
      cma = c - a
      a2n = a2nm1 + cma*a2n
      b2n = b2nm1 + cma*b2n
      an0 = a2n/b2n
      IF (abs(an0-am0).GE.eps*an0) GO TO 70
      q = r*an0
      p = 0.5D0 + (0.5D0-q)
      RETURN
C
C                SPECIAL CASES
C
   80 p = 0.0D0
      q = 1.0D0
      RETURN
C
   90 p = 1.0D0
      q = 0.0D0
      RETURN
C
  100 IF (x.GE.0.25D0) GO TO 110
      p = erf(sqrt(x))
      q = 0.5D0 + (0.5D0-p)
      RETURN

  110 q = erfc1(0,sqrt(x))
      p = 0.5D0 + (0.5D0-q)
      RETURN
C
  120 IF (x.LE.a) GO TO 80
      GO TO 90

      END


program NN
    implicit none
    real :: inputs(3),weights(3),bias,output

    inputs  = [1.2, 5.1, 2.1]
    weights = [3.1, 2.1, 8.7]
    bias    = 3

    output = inputs(1) * weights(1) +&
             inputs(2) * weights(2) +&
             inputs(3) * weights(3) +&
             bias

    print *,output
end program NN


program test

  use matrices, only: build_matrices
  use initialize_green_wave, only: initialize_tabulated_integrals
  use constants, only: pre  ! Floating point precision

  implicit none

  integer, parameter :: nb_faces = 2
  integer, parameter :: nb_vertices = 4*nb_faces
  integer, parameter :: nb_quadrature_points = 1

  real(kind=pre) :: wavenumber, depth

  ! Geometry of the mesh
  real(kind=pre), dimension(nb_vertices, 3) :: vertices
  integer, dimension(nb_faces, 4) :: faces
  real(kind=pre), dimension(nb_faces, 3) :: face_center
  real(kind=pre), dimension(nb_faces, 3) :: face_normal
  real(kind=pre), dimension(nb_faces) :: face_area
  real(kind=pre), dimension(nb_faces) :: face_radius
  real(kind=pre), dimension(nb_faces, nb_quadrature_points, 3) :: quadrature_points
  real(kind=pre), dimension(nb_faces, nb_quadrature_points) :: quadrature_weights

  ! Tabulation of the integrals used in the Green function
  integer, parameter :: tabulation_x = 328
  integer, parameter :: tabulation_z = 46
  real(kind=pre), dimension(tabulation_x)                      :: x
  real(kind=pre), dimension(tabulation_z)                      :: z
  real(kind=pre), dimension(tabulation_x, tabulation_z, 2, 2)  :: tabulation

  ! Prony decomposition for the finite depth Green function
  integer, parameter    :: nexp = 31
  real(kind=pre), dimension(nexp) :: ambda, ar

  ! The interaction matrices to be computed
  complex(kind=pre), dimension(nb_faces, nb_faces) :: S, K

  wavenumber = 1.0
  depth = 0.0  ! means infinite depth

  vertices = reshape([  &
                      0.0, 0.0, -1.0,  &
                      1.0, 0.0, -1.0,  &
                      1.0, 1.0, -1.0,  &
                      0.0, 1.0, -1.0,  &
                      1.0, 0.0, -1.0,  &
                      2.0, 0.0, -1.0,  &
                      2.0, 1.0, -1.0,  &
                      1.0, 1.0, -1.0   &
                      ], shape(vertices))
  faces = reshape([1, 2, 3, 4, 5, 6, 7, 8], shape(faces))

  face_center = reshape([0.5, 0.5, -1.0,  &
                         1.5, 0.5, -1.0], &
                        shape(face_center))
  face_normal = reshape([0.0, 0.0, 1.0,  &
                         0.0, 0.0, 1.0], &
                        shape(face_normal))

  face_area = [1.0, 1.0]
  face_radius = [0.71, 0.71]

  quadrature_points = reshape(face_center, shape(quadrature_points))
  quadrature_weights = reshape(face_area, shape(quadrature_weights))

  call build_matrices(                                           &
    nb_faces, face_center, face_normal,                          &
    nb_vertices, nb_faces, vertices, faces,                      &
    face_center, face_normal, face_area, face_radius,            &
    nb_quadrature_points, quadrature_points, quadrature_weights, &
    wavenumber, depth,                                           &
    [0d0, -0d0, 1d0],                                            &
    x, z, tabulation,                                            &
    nexp, ambda, ar,                                             &
    .false.,                                                      &
    S, K)

  print*, S
  print*, K

end program test


module looptests

  use ISO_C_BINDING

  implicit none

  contains

    subroutine gemm_mnk(C, A, B, M, K, N) BIND(C, name="gemm_mnk")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(M, K), intent(in) :: A
      real(C_double), dimension(K, N), intent(in) :: B
      integer(C_long) :: mm, kk, nn
      C = 0.0
      do concurrent(mm = 1:M)
         do concurrent(nn = 1:N)
            do concurrent(kk = 1:K)
               C(mm,nn) = C(mm,nn) + A(mm,kk) * B(kk,nn)
            end do
         end do
      end do
    end subroutine gemm_mnk
    subroutine gemm_mkn(C, A, B, M, K, N) BIND(C, name="gemm_mkn")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(M, K), intent(in) :: A
      real(C_double), dimension(K, N), intent(in) :: B
      integer(C_long) :: mm, kk, nn
      C = 0.0
      do concurrent(mm = 1:M)
         do concurrent(kk = 1:K)
            do concurrent(nn = 1:N)
               C(mm,nn) = C(mm,nn) + A(mm,kk) * B(kk,nn)
            end do
         end do
      end do
    end subroutine gemm_mkn
    subroutine gemm_nmk(C, A, B, M, K, N) BIND(C, name="gemm_nmk")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(M, K), intent(in) :: A
      real(C_double), dimension(K, N), intent(in) :: B
      integer(C_long) :: mm, kk, nn
      C = 0.0
      do concurrent(nn = 1:N)
         do concurrent(mm = 1:M)
            do concurrent(kk = 1:K)
               C(mm,nn) = C(mm,nn) + A(mm,kk) * B(kk,nn)
            end do
         end do
      end do
    end subroutine gemm_nmk
    subroutine gemm_nkm(C, A, B, M, K, N) BIND(C, name="gemm_nkm")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(M, K), intent(in) :: A
      real(C_double), dimension(K, N), intent(in) :: B
      integer(C_long) :: mm, kk, nn
      C = 0.0
      do concurrent(kk = 1:K)
         do concurrent(nn = 1:N)
            do concurrent(mm = 1:M)
               C(mm,nn) = C(mm,nn) + A(mm,kk) * B(kk,nn)
            end do
         end do
      end do
    end subroutine gemm_nkm
    subroutine gemm_kmn(C, A, B, M, K, N) BIND(C, name="gemm_kmn")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(M, K), intent(in) :: A
      real(C_double), dimension(K, N), intent(in) :: B
      integer(C_long) :: mm, kk, nn
      C = 0.0
      do concurrent(kk = 1:K)
         do concurrent(mm = 1:M)
            do concurrent(nn = 1:N)
               C(mm,nn) = C(mm,nn) + A(mm,kk) * B(kk,nn)
            end do
         end do
      end do
    end subroutine gemm_kmn
    subroutine gemm_knm(C, A, B, M, K, N) BIND(C, name="gemm_knm")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(M, K), intent(in) :: A
      real(C_double), dimension(K, N), intent(in) :: B
      integer(C_long) :: mm, kk, nn
      C = 0.0
      do concurrent(kk = 1:K)
         do concurrent(nn = 1:N)
            do concurrent(mm = 1:M)
               C(mm,nn) = C(mm,nn) + A(mm,kk) * B(kk,nn)
            end do
         end do
      end do
    end subroutine gemm_knm
    subroutine gemmbuiltin(C, A, B, M, K, N) BIND(C, name="gemmbuiltin")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(M, K), intent(in) :: A
      real(C_double), dimension(K, N), intent(in) :: B
      C = matmul(A, B)
    end subroutine gemmbuiltin
    subroutine AtmulB(C, A, B, M, K, N) BIND(C, name="AtmulB")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(K, M), intent(in) :: A
      real(C_double), dimension(K, N), intent(in) :: B
      integer(C_long) :: mm, kk, nn
      C = 0.0
      do concurrent(nn = 1:N)
         do concurrent(mm = 1:M)
            do concurrent(kk = 1:K)
               C(mm,nn) = C(mm,nn) + A(kk,mm) * B(kk,nn)
            end do
         end do
      end do
    end subroutine AtmulB
    subroutine AtmulBbuiltin(C, A, B, M, K, N) BIND(C, name="AtmulBbuiltin")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(K, M), intent(in) :: A
      real(C_double), dimension(K, N), intent(in) :: B
      integer(C_long) :: mm, kk, nn
      C = matmul(transpose(A), B)
    end subroutine AtmulBbuiltin
    subroutine dot(s, a, b, N) BIND(C, name="dot")
      integer(C_long), intent(in) :: N
      real(C_double), dimension(N), intent(in) :: a, b
      real(C_double), intent(out) :: s
      integer(C_long) :: i
      s = 0
      do concurrent(i = 1:N)
         s = s + a(i) * b(i)
      end do
    end subroutine dot
    subroutine selfdot(s, a, N) BIND(C, name="selfdot")
      integer(C_long), intent(in) :: N
      real(C_double), dimension(N), intent(in) :: a
      real(C_double), intent(out) :: s
      integer(C_long) :: i
      s = 0
      do concurrent(i = 1:N)
         s = s + a(i) * a(i)
      end do
    end subroutine selfdot
    subroutine dot3(s, x, A, y, M, N) BIND(C, name="dot3")
      integer(C_long), intent(in) :: M, N
      real(C_double), intent(in) :: x(M), A(M,N), y(N)
      real(C_double), intent(out) :: s
      integer(C_long) :: mm, nn
      do concurrent(nn = 1:N)
         do concurrent(mm = 1:M)
            s = s + x(mm) * A(mm, nn) * y(nn)
         end do
      end do
    end subroutine dot3
    !GCC$ builtin (exp) attributes simd (notinbranch) if('x86_64')
    subroutine vexp(b, a, N) BIND(C, name="vexp")
      integer(C_long), intent(in) :: N
      real(C_double), dimension(N), intent(in) :: a
      real(C_double), dimension(N), intent(out) :: b
      integer(C_long) :: i
      do concurrent(i = 1:N)
         b(i) = exp(a(i))
      end do
    end subroutine vexp
    subroutine svexp(s, a, N) BIND(C, name="svexp")
      integer(C_long), intent(in) :: N
      real(C_double), dimension(N), intent(in) :: a
      real(C_double), intent(out) :: s
      integer(C_long) :: i
      s = 0
      do concurrent(i = 1:N)
         s = s + exp(a(i))
      end do
    end subroutine svexp
    subroutine gemv(y, A, x, M, K) BIND(C, name="gemv")
      integer(C_long), intent(in) :: M, K
      real(C_double), intent(in) :: A(M,K), x(K)
      real(C_double), dimension(M), intent(out) :: y
      integer(C_long) :: mm, kk
      y = 0.0
      do concurrent(kk = 1:K)
         do concurrent(mm = 1:M)
            y(mm) = y(mm) + A(mm,kk) * x(kk)
         end do
      end do
    end subroutine gemv
    subroutine gemvbuiltin(y, A, x, M, K) BIND(C, name="gemv_builtin")
      integer(C_long), intent(in) :: M, K
      real(C_double), intent(in) :: A(M,K), x(K)
      real(C_double), dimension(M), intent(out) :: y
      integer(C_long) :: mm, kk
      y = matmul(A, x)
    end subroutine gemvbuiltin
    subroutine unscaledvar(s, A, x, M, N) BIND(C, name="unscaledvar")
      integer(C_long), intent(in) :: M, N
      real(C_double), intent(in) :: A(M,N), x(M)
      real(C_double), dimension(M), intent(out) :: s
      integer(C_long) :: mm, nn
      real(C_double) :: d
      s = 0.0
      do concurrent(nn = 1:N)
         do concurrent(mm = 1:M)
            d = A(mm,nn) - x(mm)
            s(mm) = s(mm) + d * d
         end do
      end do
    end subroutine unscaledvar
    subroutine aplusBc(D, a, B, c, M, N) BIND(C, name="aplusBc")
      integer(C_long), intent(in) :: M, N
      real(C_double), intent(in) :: a(M), B(M,N), c(N)
      real(C_double), dimension(M,N), intent(out) :: D
      integer(C_long) :: mm, nn
      do concurrent(nn = 1:N)
         do concurrent(mm = 1:M)
            D(mm,nn) = a(mm) + B(mm,nn) * c(nn)
         end do
      end do
    end subroutine aplusBc
    subroutine OLSlp(lp, y, X, b, N, P) BIND(C, name="OLSlp")
      integer(C_long), intent(in) :: N, P
      real(C_double), intent(in) :: y(N), X(N, P), b(P)
      real(C_double), intent(out) :: lp
      integer(C_long) :: nn, pp
      real(C_double) :: d
      lp = 0
      do concurrent(nn = 1:N)
         d = y(nn)
         do concurrent(pp = 1:P)
            d = d - X(nn,pp) * b(pp)
         end do
         lp = lp + d*d
      end do
    end subroutine OLSlp
end module looptests


!     .................................................
!             ____  _       _   ____  _____   _
!            |  _ \| |     |_| |  _ \|  ___| |_|
!            | |_) | |___   _  | |_) | |___   _
!            |  _ /|  _  | | | |  _ /|___  | | |
!            | |   | | | | | | | |    ___| | | |
!            |_|   |_| |_| |_| |_|   |_____| |_|
!     .................................................
!     PhiPsi:     a general-purpose computational
!                 mechanics program written in Fortran.
!     Website:    http://phipsi.top
!     Author:     Shi Fang from Huaiyin Institute of
!                 Technology, HuaiAn, JiangSu, China
!     Contact me: shifang@hyit.edu.cn
!     ------------------------------------------------
!     Please cite the following papers:
!     (1)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based method with reduction technique
!        for modeling hydraulic fracture propagation
!        in formations containing frictional natural
!        fractures. Engineering Fracture Mechanics,
!        2017, 173: 64-90.
!     (2)Shi F, Wang X L, Liu C, Liu H, Wu H A. A
!        coupled extended finite element approach
!        for modeling hydraulic fracturing in
!        consideration of proppant. Journal of
!        Natural Gas Science and Engineering, 2016,
!        33: 885-897.
!     (3)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based numerical model to calculate
!        conductivity of propped fracture considering
!        proppant transport, embedment and crushing.
!        Journal of Petroleum Science and Engineering,
!        2018, 167: 615-626..

      subroutine Cal_Ele_Stiffness_Matrix_N4(X_NODES,Y_NODES,
     &                           thick,c_D,kesi,yita,weight,
     &                           localK)
      !Calculate element stiffness matrix.

      implicit none

      double precision,intent(in)::thick,c_D(3,3),
     &                     kesi(4),yita(4),weight(4)
      double precision,intent(in):: X_NODES(4),Y_NODES(4)
      double precision,intent(out):: localK(8,8)

      integer i
      double precision X(4),Y(4),JM(4,4),a,b,c,d,
     &                Nkesi(4),Nyita(4),detJ,one,fo,
     &                B1(3,2),B2(3,2),B3(3,2),B4(3,2),ToTal_B(3,8)

      one = 1.0D0
      fo  = 4.0D0
      localK(1:8,1:8)=0.0D0

      X=[X_NODES(1),X_NODES(2),X_NODES(3),X_NODES(4)]
      Y=[Y_NODES(1),Y_NODES(2),Y_NODES(3),Y_NODES(4)]

      !Loop through each gauss point
      do i=1,4
	      JM(1,:)=[0.0D0,one-yita(i),yita(i)-kesi(i),  kesi(i)-one]
		  JM(2,:)=[yita(i)-one,0.0D0,one+kesi(i), -kesi(i)-yita(i)]
		  JM(3,:)=[kesi(i)-yita(i), -kesi(i)-one,0.0D0,yita(i)+one]
		  JM(4,:)=[one-kesi(i), yita(i)+kesi(i),-yita(i)-one,0.0D0]

	      Nkesi=[(yita(i)-one)/fo,(-yita(i)+one)/fo,
     &           (yita(i)+one)/fo,(-yita(i)-one)/fo]
	      Nyita=[(kesi(i)-one)/fo,(-kesi(i)-one)/fo,
     &           (kesi(i)+one)/fo,(-kesi(i)+one)/fo]

	      a=(Y(1)*(kesi(i)-one)+Y(2)*(-one-kesi(i))+
     *                     Y(3)*(one+kesi(i))+Y(4)*( one-kesi(i)))/fo
	      b=(Y(1)*(yita(i)-one)+Y(2)*(one-yita(i))+
     *                     Y(3)*(one+yita(i))+Y(4)*(-one-yita(i)))/fo
	      c=(X(1)*(yita(i)-one)+X(2)*(one-yita(i))+
     *                     X(3)*(one+yita(i))+X(4)*(-one-yita(i)))/fo
	      d=(X(1)*(kesi(i)-one)+X(2)*(-one-kesi(i))+
     *                     X(3)*(one+kesi(i))+X(4)*( one-kesi(i)))/fo

	      detJ  =   dot_product(MATMUL(X,JM),Y)/8.0D0

          B1(1,:)=[a*Nkesi(1)-b*Nyita(1),0.0D0 ]
	      B1(2,:)=[0.0D0, c*Nyita(1)-d*Nkesi(1)]
	      B1(3,:)=[c*Nyita(1)-d*Nkesi(1), a*Nkesi(1)-b*Nyita(1)]
	      B2(1,:)=[a*Nkesi(2)-b*Nyita(2),0.0D0 ]
	      B2(2,:)=[0.0D0 ,c*Nyita(2)-d*Nkesi(2)]
	      B2(3,:)=[c*Nyita(2)-d*Nkesi(2), a*Nkesi(2)-b*Nyita(2)]
	      B3(1,:)=[a*Nkesi(3)-b*Nyita(3),0.0D0]
	      B3(2,:)=[0.0D0 , c*Nyita(3)-d*Nkesi(3)]
	      B3(3,:)=[c*Nyita(3)-d*Nkesi(3), a*Nkesi(3)-b*Nyita(3)]
	      B4(1,:)=[a*Nkesi(4)-b*Nyita(4),0.0D0]
	      B4(2,:)=[0.0D0 ,c*Nyita(4)-d*Nkesi(4)]
	      B4(3,:)=[c*Nyita(4)-d*Nkesi(4),a*Nkesi(4)-b*Nyita(4)]

 	      ToTal_B(1:3,1:2)= B1
          ToTal_B(1:3,3:4)= B2
          ToTal_B(1:3,5:6)= B3
          ToTal_B(1:3,7:8)= B4
          ToTal_B=ToTal_B/detJ

 	      localK = localK + thick*weight(i)*detJ*
     &             MATMUL(MATMUL(transpose(ToTal_B),c_D),ToTal_B)
      end do

      return
      end SUBROUTINE Cal_Ele_Stiffness_Matrix_N4


      SUBROUTINE AB08NW( EQUIL, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD,
     $                   NFZ, NRANK, NIZ, DINFZ, NKROR, NINFE, NKROL,
     $                   INFZ, KRONR, INFE, KRONL, E, LDE, TOL, IWORK,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To extract from the system pencil
C
C                       ( A-lambda*I B )
C           S(lambda) = (              )
C                       (      C     D )
C
C     a regular pencil Af-lambda*Ef which has the finite Smith zeros of
C     S(lambda) as generalized eigenvalues. The routine also computes
C     the orders of the infinite Smith zeros and determines the singular
C     and infinite Kronecker structure of the system pencil, i.e., the
C     right and left Kronecker indices, and the multiplicities of the
C     infinite eigenvalues.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     EQUIL   CHARACTER*1
C             Specifies whether the user wishes to balance the system
C             matrix as follows:
C             = 'S':  Perform balancing (scaling);
C             = 'N':  Do not perform balancing.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER.
C             The order of the square matrix A, the number of rows of
C             the matrix B, and number of columns of the matrix C.
C             N >= 0.
C
C     M       (input) INTEGER.
C             The number of columns of the matrix B.  M >= 0.
C
C     P       (input) INTEGER.
C             The number of rows of the matrix C.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the state dynamics matrix A of the system.
C             On exit, the leading NFZ-by-NFZ part of this array
C             contains the matrix Af of the reduced pencil.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the input/state matrix B of the system.
C             On exit, this matrix does not contain useful information.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= 1, and
C             LDB >= MAX(1,N), if M > 0.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix C of the system.
C             On exit, this matrix does not contain useful information.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1,P).
C
C     D       (input) DOUBLE PRECISION array, dimension (LDD,M)
C             The leading P-by-M part of this array must contain the
C             direct transmission matrix D of the system.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= MAX(1,P).
C
C     NFZ     (output) INTEGER
C             The number of finite zeros.
C
C     NRANK   (output) INTEGER
C             The normal rank of the system pencil.
C
C     NIZ     (output) INTEGER
C             The number of infinite zeros.
C
C     DINFZ   (output) INTEGER
C             The maximal multiplicity of infinite Smith zeros.
C
C     NKROR   (output) INTEGER
C             The number of right Kronecker indices.
C
C     NINFE   (output) INTEGER
C             The number of elementary infinite blocks.
C
C     NKROL   (output) INTEGER
C             The number of left Kronecker indices.
C
C     INFZ    (output) INTEGER array, dimension (N+1)
C             The leading DINFZ elements of INFZ contain information
C             on the infinite elementary divisors as follows:
C             the system has INFZ(i) infinite elementary divisors in
C             the Smith form of degree i, where i = 1,2,...,DINFZ.
C
C     KRONR   (output) INTEGER array, dimension (N+1)
C             The leading NKROR elements of this array contain the
C             right Kronecker (column) indices.
C
C     INFE    (output) INTEGER array, dimension (N+1)
C             The leading NINFE elements of INFE contain the
C             multiplicities of infinite eigenvalues.
C
C     KRONL   (output) INTEGER array, dimension (N+1)
C             The leading NKROL elements of this array contain the
C             left Kronecker (row) indices.
C
C     E       (output) DOUBLE PRECISION array, dimension (LDE,N)
C             The leading NFZ-by-NFZ part of this array contains the
C             matrix Ef of the reduced pencil.
C
C     LDE     INTEGER
C             The leading dimension of the array E.  LDE >= MAX(1,N).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             A tolerance used in rank decisions to determine the
C             effective rank, which is defined as the order of the
C             largest leading (or trailing) triangular submatrix in the
C             QR (or RQ) factorization with column (or row) pivoting
C             whose estimated condition number is less than 1/TOL.
C             If the user sets TOL <= 0, then an implicitly computed,
C             default tolerance  TOLDEF = MAX(N+P,N+M)**2*EPS,  is used
C             instead, where EPS is the machine precision (see LAPACK
C             Library routine DLAMCH).  TOL < 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (MAX(M,P))
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 1, if MAX(N,M,P) = 0; otherwise,
C             LDWORK >= MAX( MIN(P,M) + M + MAX(2*M,N) - 1,
C                            MIN(P,N) + MAX(N + MAX(P,M), 3*P - 1 ) ) +
C                            MAX(P+N,M+N)*MAX(P+N,M+N).
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
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 routine extracts from the system matrix of a state space
C     system, (A-lambda*I,B,C,D), a regular pencil Af-lambda*Ef, which
C     has the finite zeros of the system as generalized eigenvalues.
C     The procedure has the following main computational steps:
C
C        (a) construct the (N+P)-by-(M+N) system pencil
C
C             S(lambda) = (B  A)-lambda*( 0  I );
C                         (D  C)        ( 0  0 )
C
C        (b) reduce S(lambda) to S1(lambda) with the same finite zeros
C            and right Kronecker structure, but with D of full row rank;
C
C        (c) reduce the pencil S1(lambda) to S2(lambda) with the same
C            finite zeros and with D square invertible;
C
C        (d) perform a unitary transformation on the columns of
C            S2(lambda) = (A-lambda*I   B), in order to reduce it to
C                         (     C       D)
C
C            (Af-lambda*Ef   X), with Y and Ef square invertible;
C            (     0         Y)
C
C        (e) compute the right and left Kronecker indices of the system
C            matrix, which, together with the multiplicities of the
C            finite and infinite eigenvalues, constitute the complete
C            set of structural invariants under strict equivalence
C            transformations of a linear system.
C
C     REFERENCES
C
C     [1] Svaricek, F.
C         Computation of the Structural Invariants of Linear
C         Multivariable Systems with an Extended Version of the
C         Program ZEROS.
C         System & Control Letters, 6, pp. 261-266, 1985.
C
C     [2] Emami-Naeini, A. and Van Dooren, P.
C         Computation of Zeros of Linear Multivariable Systems.
C         Automatica, 18, pp. 415-430, 1982.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable (see [2] and [1]).
C
C     FURTHER COMMENTS
C
C     In order to compute the finite Smith zeros of the system
C     explicitly, a call to this routine may be followed by a call to
C     the LAPACK Library routine DGGEV.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     V. Sima, Katholieke Univ. Leuven, Belgium, May 1999.
C
C     REVISIONS
C
C     A. Varga, May 2003, German Aerospace Center, DLR Oberpfaffenhofen.
C     V. Sima, Dec. 2016, Jan. 2017, Apr. 2017.
C
C     KEYWORDS
C
C     Generalized eigenvalue problem, Kronecker indices, multivariable
C     system, orthogonal transformation, structural invariant.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         EQUIL
      INTEGER           DINFZ, INFO, LDA, LDB, LDC, LDD, LDE, LDWORK,
     $                  M, N, NFZ, NINFE, NIZ, NKROL, NKROR, NRANK, P
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           INFE(*),  INFZ(*),  IWORK(*), KRONL(*), KRONR(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                  DWORK(*), E(LDE,*)
C     .. Local Scalars ..
      LOGICAL           LEQUIL, LQUERY, QRET
      INTEGER           I, I0, I1, II, ITAU, J, JWORK, KABCD, LABCD2,
     $                  LDABCD, MM, MPM, MPN, MU, NN, NSINFE, NU, NU1,
     $                  PP, WRKOPT
      DOUBLE PRECISION  MAXRED, SVLMAX, TOLER
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANGE
      EXTERNAL          DLAMCH, DLANGE, LSAME
C     .. External Subroutines ..
      EXTERNAL          AB08NY, DLACPY, DLASET, DORMRZ, DTZRZF, MA02BD,
     $                  TB01ID, TB01XD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX, MIN
C     .. Executable Statements ..
C
      INFO   = 0
      LDABCD = N + MAX( P, M )
      LABCD2 = LDABCD*LDABCD
      LEQUIL = LSAME( EQUIL, 'S' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LEQUIL .AND. .NOT.LSAME( EQUIL, 'N' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( P.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.1 .OR. ( M.GT.0 .AND. LDB.LT.N ) ) THEN
         INFO = -8
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -10
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -12
      ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -25
      ELSE IF( TOL.GE.ONE ) THEN
         INFO = -26
      ELSE
         MPN  = MIN( P, N )
         MPM  = MIN( P, M )
         QRET = MAX( N, M, P ).EQ.0
         LQUERY = ( LDWORK.EQ.-1 )
         IF( QRET ) THEN
            JWORK = 1
         ELSE
            JWORK = MAX( MPM + M + MAX( 2*M, N ) - 1,
     $                   MPN + MAX( LDABCD, 3*P  - 1 ) ) + LABCD2
         END IF
         IF( LQUERY ) THEN
            IF( QRET ) THEN
               WRKOPT = 1
            ELSE
               SVLMAX = ZERO
               NIZ    = 0
               CALL AB08NY( .TRUE., N, M, P, SVLMAX, DWORK, LDABCD, NIZ,
     $                      NU, MU, DINFZ, NKROL, INFZ, KRONL, TOL,
     $                      IWORK, DWORK, -1, INFO )
               WRKOPT = MAX( JWORK, LABCD2 + INT( DWORK(1) ) )
               CALL AB08NY( .FALSE., N, M, M, SVLMAX, DWORK, LDABCD,
     $                      NIZ, NU, MU, I1, NKROR, IWORK, KRONR, TOL,
     $                      IWORK, DWORK, -1, INFO )
               WRKOPT = MAX( WRKOPT, LABCD2 + INT( DWORK(1) ) )
               CALL DTZRZF( MPM, N+MPM, DWORK, LDABCD, DWORK, DWORK, -1,
     $                      INFO )
               WRKOPT = MAX( WRKOPT, LABCD2 + MPM + INT( DWORK(1) ) )
               CALL DORMRZ( 'Right', 'Transpose', N, N+MPM, MPM, N,
     $                      DWORK, LDABCD, DWORK, DWORK, LDABCD, DWORK,
     $                      -1, INFO )
               WRKOPT = MAX( WRKOPT, LABCD2 + MPM + INT( DWORK(1) ) )
            END IF
         ELSE IF( LDWORK.LT.JWORK ) THEN
            INFO = -29
         END IF
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB08NW', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
      NIZ   = 0
      NKROL = 0
      NKROR = 0
      NINFE = 0
C
C     Quick return if possible.
C
      IF( QRET ) THEN
         DINFZ = 0
         NFZ   = 0
         NRANK = 0
         DWORK(1) = ONE
         RETURN
      END IF
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real workspace needed at that point in the
C     code, as well as the preferred amount for good performance.)
C
      WRKOPT = 1
      KABCD  = 1
      JWORK  = KABCD + LABCD2
C
C     If required, balance the system pencil.
C     Workspace: need   N.
C
      IF( LEQUIL ) THEN
         MAXRED = ZERO
         CALL TB01ID( 'A', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC,
     $                DWORK, INFO )
         WRKOPT = N
      END IF
C
C     Construct the system pencil
C
C                      ( B A-lambda*I )
C         S(lambda) =  (              )
C                      ( D     C      )
C
C     of dimension (N+P)-by-(M+N).
C
      NN = N
      MM = M
      PP = P
C
      CALL DLACPY( 'Full', N, M, B, LDB, DWORK(KABCD),          LDABCD )
      CALL DLACPY( 'Full', P, M, D, LDD, DWORK(KABCD+N),        LDABCD )
      CALL DLACPY( 'Full', N, N, A, LDA, DWORK(KABCD+LDABCD*M), LDABCD )
      CALL DLACPY( 'Full', P, N, C, LDC, DWORK(KABCD+LDABCD*M+N),
     $              LDABCD )
C
C     If required, set tolerance.
C
      TOLER = TOL
      IF( TOLER.LE.ZERO ) THEN
         TOLER = DBLE( LABCD2 ) * DLAMCH( 'Precision' )
      END IF
      SVLMAX = DLANGE( 'Frobenius', NN+PP, NN+MM, DWORK(KABCD), LDABCD,
     $                 DWORK(JWORK) )
C
C     Extract the reduced pencil S1(lambda)
C
C             ( Bc  Ac-lambda*I ),
C             ( Dc      Cc      )
C
C     having the same finite Smith zeros as the system pencil S(lambda),
C     but with Dc, a MU-by-MM full row rank left upper-trapezoidal
C     matrix, with the first MU columns in an upper triangular form.
C
C     Workspace: need   MAX( MIN(P,M) + M + MAX(2*M,N) - 1,
C                            MIN(P,N) + MAX(N + MAX(P,M), 3*P - 1 ) ).
C                prefer larger.
C     Int.work.  need   MAX(M,P).
C
      CALL AB08NY( .TRUE., NN, MM, PP, SVLMAX, DWORK(KABCD), LDABCD,
     $             NIZ, NU, MU, DINFZ, NKROL, INFZ, KRONL, TOLER, IWORK,
     $             DWORK(JWORK), LDWORK-JWORK+1, INFO )
C
      WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
C
C     Set the number of simple (non-dynamic) infinite eigenvalues, and
C     the normal rank of the system pencil.
C
      NSINFE = MU
      NRANK  = NN + MU
C
C     Pertranspose the system.
C
      CALL TB01XD( 'D', NU, MM, MM, MAX( 0, NU-1 ), MAX( 0, NU-1 ),
     $              DWORK(KABCD+LDABCD*MM),    LDABCD,
     $              DWORK(KABCD),              LDABCD,
     $              DWORK(KABCD+LDABCD*MM+NU), LDABCD,
     $              DWORK(KABCD+NU),           LDABCD, INFO )
      CALL MA02BD( 'Right', NU+MM, MM, DWORK(KABCD),    LDABCD )
      CALL MA02BD( 'Left',  MM, NU+MM, DWORK(KABCD+NU), LDABCD )
C
      IF( MU.NE.MM ) THEN
         NN = NU
         PP = MM
         MM = MU
         KABCD = KABCD + ( PP - MM )*LDABCD
C
C        Extract the reduced pencil S2(lambda) to
C
C             ( Br  Ar-lambda*I ),
C             ( Dr      Cr      )
C
C        having the same finite Smith zeros as the pencil S(lambda),
C        but with Dr, a MU-by-MU invertible upper-triangular matrix.
C
C        Workspace: need  MAX( MIN(P,M) + M + MAX(2*M,N) - 1,
C                              MIN(P,N) + MAX(N + MAX(P,M), 3*P-1 ) ).
C                   prefer larger.
C
         CALL AB08NY( .FALSE., NN, MM, PP, SVLMAX, DWORK(KABCD), LDABCD,
     $                I0, NU, MU, I1, NKROR, IWORK, KRONR, TOLER,
     $                IWORK, DWORK(JWORK), LDWORK-JWORK+1, INFO )
C
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
      END IF
C
      IF( MIN( NU, MU ).NE.0 ) THEN
C
C        Perform a unitary transformation on the columns of
C                     ( Br Ar-lambda*I  ),
C                     ( Dr     Cr       )
C        in order to reduce it to
C                     ( Af-lambda*Ef  * ),
C                     (      0        Y )
C        with Y and Ef square invertible.
C
         NU1   = NU + KABCD
         I1    = NU + MU
         ITAU  = JWORK
         JWORK = ITAU + MU
C
C        Workspace: need   2*MIN(P,M);
C                   prefer MIN(P,M) + MIN(P,M)*NB.
C
         CALL DTZRZF( MU, I1, DWORK(NU1), LDABCD, DWORK(ITAU),
     $                DWORK(JWORK), LDWORK-JWORK+1, INFO )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
C
C        Compute and save Af.
C
C        Workspace: need   MIN(P,M) + N;
C                   prefer MIN(P,M) + N*NB.
C
         CALL DORMRZ( 'Right', 'Transpose', NU, I1, MU, NU,
     $                DWORK(NU1), LDABCD, DWORK(ITAU), DWORK(KABCD),
     $                LDABCD, DWORK(JWORK), LDWORK-JWORK+1, INFO )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
C
         CALL DLACPY( 'Full', NU, NU, DWORK(KABCD+MU*LDABCD), LDABCD, A,
     $                LDA )
C
C        Compute and save Ef.
C
         CALL DLASET( 'Full', NU, MU, ZERO, ZERO, DWORK(KABCD), LDABCD )
         CALL DLASET( 'Full', NU, NU, ZERO, ONE, DWORK(KABCD+MU*LDABCD),
     $                LDABCD )
         CALL DORMRZ( 'Right', 'Transpose', NU, I1, MU, NU,
     $                DWORK(NU1), LDABCD, DWORK(ITAU), DWORK(KABCD),
     $                LDABCD, DWORK(JWORK), LDWORK-JWORK+1, INFO )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) ) + JWORK - 1 )
C
         CALL DLACPY( 'Full', NU, NU, DWORK(KABCD+MU*LDABCD), LDABCD, E,
     $                LDE )
      ELSE
C
C        Save Af and set Ef.
C
         CALL DLACPY( 'Full', NU, NU, DWORK(KABCD+MU*LDABCD), LDABCD, A,
     $                LDA )
         CALL DLASET( 'Full', NU, NU, ZERO, ONE, E, LDE )
      END IF
C
      NFZ = NU
C
C     Set right Kronecker indices (column indices).
C
      DO 30 I = 1, NKROR
         IWORK(I) = KRONR(I)
   30 CONTINUE
C
      J = 0
C
      DO 50 I = 1, NKROR
         DO 40 II = J + 1, J + IWORK(I)
            KRONR(II) = I - 1
   40    CONTINUE
C
         J = J + IWORK(I)
   50 CONTINUE
C
      NKROR = J
C
C     Set left Kronecker indices (row indices).
C
      DO 60 I = 1, NKROL
         IWORK(I) = KRONL(I)
   60 CONTINUE
C
      J = 0
C
      DO 80 I = 1, NKROL
         DO 70 II = J + 1, J + IWORK(I)
            KRONL(II) = I - 1
   70    CONTINUE
C
         J = J + IWORK(I)
   80 CONTINUE
C
      NKROL = J
C
C     Determine the number of simple infinite blocks as the difference
C     between the order of Dr and the number of infinite blocks of order
C     greater than one.
C
      DO 90 I = 1, DINFZ
         NINFE = NINFE + INFZ(I)
   90 CONTINUE
C
      NINFE = NSINFE - NINFE
C
      DO 100 I = 1, NINFE
         INFE(I) = 1
  100 CONTINUE
C
C     Set the structure of infinite eigenvalues.
C
      DO 120 I = 1, DINFZ
C
         DO 110 II = NINFE + 1, NINFE + INFZ(I)
            INFE(II) = I + 1
  110    CONTINUE
C
         NINFE = NINFE + INFZ(I)
  120 CONTINUE
C
      DWORK(1) = WRKOPT
      RETURN
C *** Last line of AB08NW ***
      END