      MODULE m_efnewton
      use m_juDFT
      CONTAINS
      RECURSIVE SUBROUTINE ef_newton(
     >     n,irank,
     >     inkem,nocst,index,tkb,e,
     X     w_near_ef,ef,we,recursion_level)

c***********************************************************************
c
c     This subroutine adjusts the Fermi-Energy to obtain charge
c     neutrality. This is done by solving
c
c     ( sum ff(e) * we ) - w_near_ef = 0
c     e
c
c     using the Newton-Method.
c     Here the sum is over the eigenvalues between ef-8kt and ef+8kt,
c     ff is the Fermi-Function, we is the weight of the according
c     k-point and w_near_ef is the weight required between ef-8kt
c     and ef+8kt to obtain neutrality.
c
c***********************************************************************

      USE m_constants

      IMPLICIT NONE

C     .. Scalar Arguments ..
      INTEGER, INTENT (IN)    :: n
      INTEGER, INTENT (IN)    :: inkem,nocst,irank
      REAL,    INTENT (IN)    :: tkb
      REAL,    INTENT (INOUT) :: ef,w_near_ef
      INTEGER,INTENT(IN),OPTIONAL:: recursion_level
C     ..
C     .. Array Arguments ..
      INTEGER, INTENT (IN)    :: index(n)
      REAL,    INTENT (IN)    :: e(:) !(nkptd*neigd*jspd)
      REAL,    INTENT (INOUT) :: we(:) !(nkptd*neigd*jspd)
C     ..
C     .. Local Scalars ..
      REAL dff,expo,sdff,sff,efmin,efmax
      INTEGER icnt,idim,rec_level
      LOGICAL efminok,efmaxok

C     ..
C     .. Local Arrays ..
      REAL ff(size(e))
C     ..
C     .. Parameters ..
      REAL,PARAMETER:: eps=1.0e-10
C     ..
c***********************************************************************
c     ABBREVIATIONS
c
c     e          : linear list of the eigenvalues within the highest
c     energy-window
c     we         : list of weights of the eigenvalues in e
c     ef         : fermi energy determined to obtain charge neutrality
c     tkb        : value of temperature (kt) broadening around fermi
c     energy in htr units
c     index      : index list, e(index(n)) is the list of the
c     eigenvalues in ascending order
c     ikem       : number of eigenvalues below ef-8kt
c     nocst      : number of eigenvalues below ef+8kt
c     w_near_ef  : weight (charge/spindg) between ef-8kt and ef+8kt
c     needed to obtain charge neutrality
c
c***********************************************************************

      IF (PRESENT(recursion_level)) THEN
         rec_level=recursion_level+1
         IF (rec_level>20) CALL juDFT_error
     +     ("Determination of fermi-level did not converge",hint=
     + 'change temp. broad., set gauss = T, or use finer k mesh',
     + calledby="ef_newton")
      ELSE
         rec_level=0
         IF ( irank == 0 ) WRITE (oUnit,FMT='(/,5x,''EF_NEWTON:  '',
     +''Adjust Fermi-Energy by Newton-Method.'',/)')
      ENDIF
c
c     --->    NEWTON CYCLE
c
      efminok= .false.
      efmaxok= .false.
      DO icnt = 1,50
         sff = 0.0
         sdff = 0.0
         DO idim = inkem + 1,nocst
c
c --->    COMPUTE FERMI-FUNCTION ff AND THE DERIVATIVE dff
c
            expo= -ABS(e(index(idim))-ef)/tkb
            expo= EXP(expo)
            IF (e(index(idim))<ef) THEN
               ff(idim) = 1./ (expo+1.)
            ELSE
               ff(idim)= expo/ (expo+1.)
            ENDIF
            dff= (1.+expo)**2
            dff= expo/(dff*tkb)
c
c     --->    MULTIPLY WITH THE WEIGHT
c
            ff(idim) = we(index(idim))*ff(idim)
            dff = we(index(idim))*dff
c
c     --->    AND SUM IT UP
c
            sff = sff + ff(idim)
            sdff = sdff + dff
         END DO
         sff = sff - w_near_ef
         IF (abs(sff).LT.eps) THEN
            !Converged, so do some output and return
            w_near_ef = sff + w_near_ef
            IF (irank == 0) WRITE (oUnit,FMT=8010) icnt,sff,-sff/sdff

            DO idim = inkem + 1,nocst
               we(index(idim)) = ff(idim)
            END DO

 8000  FORMAT (15x,'ef_newton failed after      :',i3,'iterations.',/,
     +           15x,'The error in the weight is  : ',e12.5,/,
     +           15x,'The error in ef is          : ',e12.5,' htr',/)
 8010       FORMAT (15x,'Number of iterations needed  : ',i3,/,
     +           15x,'The error in the weight is   : ',e12.5,/,
     +           15x,'The error in ef is           : ',e12.5,' htr',/)
            RETURN
         ENDIF

         IF (abs(sdff).LT.1e-29) THEN
            if (irank==0) THEN
         write(oUnit,*) "Instability in determination of fermi-level,"
         write(oUnit,*) "doubled temperature broading to continue"
         write(*,*) "Instability in determination of fermi-level,"
         write(*,*) "doubled temperature broading to continue"
            ENDIF
            CALL  ef_newton(
     >             n,irank,
     >             inkem,nocst,index,tkb*2.0,e,
     X             w_near_ef,ef,we,rec_level)
            RETURN
         ENDIF
         IF (sff > 0.) THEN
           efmax= ef
           efmaxok= .true.
         ELSE
           efmin= ef
           efminok= .true.
         ENDIF
         ef = ef - sff/sdff
         ! if the Newton method is not stable, nested intervals are used
         IF ( efminok .and. efmaxok ) THEN
           IF ( (ef<efmin) .or. (ef>efmax) ) THEN
             ef= (efmin+efmax)/2.
           ENDIF
         ENDIF
      END DO
c
c---  > NOT CONVERGED AFTER 50 ITERATIONS
c
      IF ( irank == 0 ) WRITE (oUnit,FMT=8000) icnt,sff,-sff/sdff
      ef=ef+0.001
      CALL  ef_newton(
     >     n,irank,
     >     inkem,nocst,index,tkb*2.0,e,
     X     w_near_ef,ef,we,rec_level)

      END SUBROUTINE ef_newton
      END MODULE m_efnewton


MODULE init_warm_bubble
  USE defs, ONLY : pi, cp
  USE mo_aux_state, ONLY : xt,yt,zt,pi0,pi1
  USE mo_progn_state, ONLY : a_tp
  USE grid, ONLY : nxp,nyp,nzp,level
  USE mo_structured_datatypes

  IMPLICIT NONE

  ! -----------------------------------------------------------------
  ! Contains routines and parameters for setting up a warm bubble in
  ! the beginning of simulation to initialize deep convection. the
  ! warm bubble initialization will be called instead of the random
  ! perturbations routine.
  ! -----------------------------------------

  REAL :: bubble_center(3) = [1000.,0.,0.]        ! z,x,y, meters, determined from
                                                  ! grid point displacements
  REAL :: bubble_diameter(3) = [500.,1000.,1000.] ! z,x,y, meters
  REAL :: bubble_temp_ampl = 1.5                  ! Kelvins

  CONTAINS

    SUBROUTINE warm_bubble()
      IMPLICIT NONE

      INTEGER :: i,j,k
      REAL :: total_dist_norm
      REAL :: coord(3)
      REAL :: exner

      WRITE(*,*) '------------------------------'
      WRITE(*,*) 'INITIALIZING WARM BUBBLE'
      WRITE(*,*) '------------------------------'

      coord = 0.

      DO j = 3,nyp-2
         DO i = 3,nxp-2
            DO k = 2,nzp

               coord = [zt%d(k),xt%d(i),yt%d(j)]
               total_dist_norm = SQRT( SUM( ((coord-bubble_center)/(0.5*bubble_diameter))**2 ) )

               !IF ( k<10 ) WRITE(*,*) k,i,j,total_dist_norm, coord-bubble_center

               IF ( total_dist_norm < 1. ) THEN

                  ! Add the temperature perturbation to the liquid potential temperature
                  ! (Just a straightforward addition, don't worry about the resulting decrease in RH?)

                  exner = (pi0%d(k) + pi1%d(k))/cp
                  !WRITE(*,*) k,i,j, exner, SIN( (1.-total_dist_norm)*0.5*pi ),zt(k)
                  a_tp%d(k,i,j) = a_tp%d(k,i,j) +   &
                       SIN( (1.-total_dist_norm)*0.5*pi )*bubble_temp_ampl!/exner

               END IF

            END DO
         END DO
      END DO

    END SUBROUTINE warm_bubble

END MODULE init_warm_bubble


C******************** START FILE SEVAL.FOR ; GROUP TRKRLIB *************
C
      REAL*8 FUNCTION r8seval(N, U, X, Y, B, C, D)
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER N
      REAL*8  U, X(N), Y(N), B(N), C(N), D(N)
C
CCCCCCCCCCCCCCC
CCCCCCCCCCCCCCC
C  THIS SUBROUTINE EVALUATES THE CUBIC SPLINE FUNCTION
C
C    SEVAL = Y(I) + B(I)*(U-X(I)) + C(I)*(U-X(I))**2 + D(I)*(U-X(I))**3
C
C    WHERE  X(I) .LT. U .LT. X(I+1), USING HORNER'S RULE
C
C  IF  U .LT. X(1) THEN  I = 1  IS USED.
C  IF  U .GE. X(N) THEN  I = N  IS USED.
C
C  INPUT..
C
C    N = THE NUMBER OF DATA POINTS
C    U = THE ABSCISSA AT WHICH THE SPLINE IS TO BE EVALUATED
C    X,Y = THE ARRAYS OF DATA ABSCISSAS AND ORDINATES
C    B,C,D = ARRAYS OF SPLINE COEFFICIENTS COMPUTED BY SPLINE
C
C  IF  U  IS NOT IN THE SAME INTERVAL AS THE PREVIOUS CALL, THEN A
C  BINARY SEARCH IS PERFORMED TO DETERMINE THE PROPER INTERVAL.
C
      INTEGER I, J, K
      REAL*8 DX
      DATA I/1/
      IF ( I .GE. N ) I = 1
      IF ( U .LT. X(I) ) GO TO 10
      IF ( U .LE. X(I+1) ) GO TO 30
C
C  BINARY SEARCH
C
   10 I = 1
      J = N+1
   20 K = (I+J)/2
      IF ( U .LT. X(K) ) J = K
      IF ( U .GE. X(K) ) I = K
      IF ( J .GT. I+1 ) GO TO 20
C
C  EVALUATE SPLINE
C
   30 DX = U - X(I)
      r8seval = Y(I) + DX*(B(I) + DX*(C(I) + DX*D(I)))
C
      RETURN
      END
C******************** END FILE SEVAL.FOR ; GROUP TRKRLIB ***************


program main
    use, intrinsic :: iso_fortran_env, only : I8 => INT64, error_unit
    use :: random_mod, only : random_bitvector
    implicit none
    integer(Kind=I8) :: nr_values
    logical, dimension(:), allocatable :: bitvector
    integer :: status

    call get_arguments(nr_values)
    bitvector = random_bitvector(nr_values, status)
    if (status /= 0) then
        write (unit=error_unit, fmt='(A, I0)') 'error: can not allocate bitvector of size ', nr_values
        stop 3
    end if
    print '(A, I0)', 'nr. true: ', count(bitvector)

contains

    subroutine get_arguments(nr_values)
        implicit none
        integer(kind=I8), intent(out) :: nr_values
        character(len=1024) :: buffer, msg
        integer :: status

        if (command_argument_count() /= 1) then
            write (unit=error_unit, fmt='(A)') 'error: expecting number of values as argument'
            stop 1
        end if
        call get_command_argument(1, buffer)
        read (buffer, fmt=*, iomsg=msg, iostat=status) nr_values
        if (status /= 0) then
            write (unit=error_unit, fmt='(A, A)') 'error: ', trim(msg)
            stop 2
        end if
        if (nr_values < 0) then
            write (unit=error_unit, fmt='(A)') 'error: number of values should be positive'
            stop 2
        end if
    end subroutine get_arguments

end program main


module quadpack

  use, intrinsic :: iso_c_binding, only: c_double
  private dqelg, dqk21, dqpsrt
  public dqagse

  abstract interface
     ! f: real(c_double) --> real(c_double)
     real(c_double) function scalar_func(x)
       use, intrinsic :: iso_c_binding, only: c_double
       implicit none

       real(c_double), intent(in) :: x
     end function scalar_func
  end interface

contains

subroutine dqagse(f,a,b,epsabs,epsrel,limit,result,abserr,neval, &
     ier,alist,blist,rlist,elist,iord,last)

!*****************************************************************************80
!
!! DQAGSE estimates the integral of a function.
!
! D - double precision
! Q - quadrature
! A - adaptive
! G - General integrand (i.e. INT f(x), not weighted INT w(x) f(x))
! S - Singularities handled
! E - Extended
!
!  Modified:
!
!    11 September 2015
!
!  Author:
!
!    Robert Piessens, Elise de Doncker
!
!***purpose  the routine calculates an approximation result to a given
!      definite integral i = integral of f over (a,b),
!      hopefully satisfying following claim for accuracy
!      abs(i-result).le.max(epsabs,epsrel*abs(i)).
!
!  Parameters:
!
!   on entry
!      f      - real ( kind = 8 )
!               function subprogram defining the integrand
!               function f(x). the actual name for f needs to be
!               declared e x t e r n a l in the driver program.
!
!      a      - real ( kind = 8 )
!               lower limit of integration
!
!      b      - real ( kind = 8 )
!               upper limit of integration
!
!      epsabs - real ( kind = 8 )
!               absolute accuracy requested
!      epsrel - real ( kind = 8 )
!               relative accuracy requested
!               if  epsabs.le.0
!               and epsrel.lt.max(50*rel.mach.acc.,0.5d-28),
!               the routine will end with ier = 6.
!
!      limit  - integer ( kind = 4 )
!               gives an upperbound on the number of subintervals
!               in the partition of (a,b)
!
!   on return
!      result - real ( kind = 8 )
!               approximation to the integral
!
!      abserr - real ( kind = 8 )
!               estimate of the modulus of the absolute error,
!               which should equal or exceed abs(i-result)
!
!      neval  - integer ( kind = 4 )
!               number of integrand evaluations
!
!      ier    - integer ( kind = 4 )
!               ier = 0 normal and reliable termination of the
!                       routine. it is assumed that the requested
!                       accuracy has been achieved.
!               ier.gt.0 abnormal termination of the routine
!                       the estimates for integral and error are
!                       less reliable. it is assumed that the
!                       requested accuracy has not been achieved.
!      error messages
!                   = 1 maximum number of subdivisions allowed
!                       has been achieved. one can allow more sub-
!                       divisions by increasing the value of limit
!                       (and taking the according dimension
!                       adjustments into account). however, if
!                       this yields no improvement it is advised
!                       to analyze the integrand in order to
!                       determine the integration difficulties. if
!                       the position of a local difficulty can be
!                       determined (e.g. singularity,
!                       discontinuity within the interval) one
!                       will probably gain from splitting up the
!                       interval at this point and calling the
!                       integrator on the subranges. if possible,
!                       an appropriate special-purpose integrator
!                       should be used, which is designed for
!                       handling the type of difficulty involved.
!                   = 2 the occurrence of roundoff error is detec-
!                       ted, which prevents the requested
!                       tolerance from being achieved.
!                       the error may be under-estimated.
!                   = 3 extremely bad integrand behaviour
!                       occurs at some points of the integration
!                       interval.
!                   = 4 the algorithm does not converge.
!                       roundoff error is detected in the
!                       extrapolation table.
!                       it is presumed that the requested
!                       tolerance cannot be achieved, and that the
!                       returned result is the best which can be
!                       obtained.
!                   = 5 the integral is probably divergent, or
!                       slowly convergent. it must be noted that
!                       divergence can occur with any other value
!                       of ier.
!                   = 6 the input is invalid, because
!                       epsabs.le.0 and
!                       epsrel.lt.max(50*rel.mach.acc.,0.5d-28).
!                       result, abserr, neval, last, rlist(1),
!                       iord(1) and elist(1) are set to zero.
!                       alist(1) and blist(1) are set to a and b
!                       respectively.
!
!      alist  - real ( kind = 8 )
!               vector of dimension at least limit, the first
!                last  elements of which are the left end points
!               of the subintervals in the partition of the
!               given integration range (a,b)
!
!      blist  - real ( kind = 8 )
!               vector of dimension at least limit, the first
!                last  elements of which are the right end points
!               of the subintervals in the partition of the given
!               integration range (a,b)
!
!      rlist  - real ( kind = 8 )
!               vector of dimension at least limit, the first
!                last  elements of which are the integral
!               approximations on the subintervals
!
!      elist  - real ( kind = 8 )
!               vector of dimension at least limit, the first
!                last  elements of which are the moduli of the
!               absolute error estimates on the subintervals
!
!      iord   - integer ( kind = 4 )
!               vector of dimension at least limit, the first k
!               elements of which are pointers to the
!               error estimates over the subintervals,
!               such that elist(iord(1)), ..., elist(iord(k))
!               form a decreasing sequence, with k = last
!               if last.le.(limit/2+2), and k = limit+1-last
!               otherwise
!
!      last   - integer ( kind = 4 )
!               number of subintervals actually produced in the
!               subdivision process
!
!  Local parameters:
!
!      the dimension of rlist2 is determined by the value of
!      limexp in routine dqelg (rlist2 should be of dimension
!      (limexp+2) at least).
!
!      list of major variables
!
!     alist     - list of left end points of all subintervals
!                 considered up to now
!     blist     - list of right end points of all subintervals
!                 considered up to now
!     rlist(i)  - approximation to the integral over
!                 (alist(i),blist(i))
!     rlist2    - array of dimension at least limexp+2 containing
!                 the part of the epsilon table which is still
!                 needed for further computations
!     elist(i)  - error estimate applying to rlist(i)
!     maxerr    - pointer to the interval with largest error
!                 estimate
!     errmax    - elist(maxerr)
!     erlast    - error on the interval currently subdivided
!                 (before that subdivision has taken place)
!     area      - sum of the integrals over the subintervals
!     errsum    - sum of the errors over the subintervals
!     errbnd    - requested accuracy max(epsabs,epsrel*
!                 abs(result))
!     *****1    - variable for the left interval
!     *****2    - variable for the right interval
!     last      - index for subdivision
!     nres      - number of calls to the extrapolation routine
!     numrl2    - number of elements currently in rlist2. if an
!                 appropriate approximation to the compounded
!                 integral has been obtained it is put in
!                 rlist2(numrl2) after numrl2 has been increased
!                 by one.
!     small     - length of the smallest interval considered up
!                 to now, multiplied by 1.5
!     erlarg    - sum of the errors over the intervals larger
!                 than the smallest interval considered up to now
!     extrap    - logical variable denoting that the routine is
!                 attempting to perform extrapolation i.e. before
!                 subdividing the smallest interval we try to
!                 decrease the value of erlarg.
!     noext     - logical variable denoting that extrapolation
!                 is no longer allowed (true value)
!
!      machine dependent constants
!
!     epmach is the largest relative spacing.
!     uflow is the smallest positive magnitude.
!     oflow is the largest positive magnitude.
!
  implicit none

  real ( kind = 8 ) a,abseps,abserr,alist,area,area1,area12,area2,a1, &
    a2,b,blist,b1,b2,correc,defabs,defab1,defab2, &
    dres,elist,epmach,epsabs,epsrel,erlarg,erlast,errbnd,errmax, &
    error1,error2,erro12,errsum,ertest,oflow,resabs,reseps,result, &
    res3la,rlist,rlist2,small,uflow
  integer ( kind = 4 ) id,ier,ierro,iord,iroff1,iroff2,iroff3,jupbnd, &
    k,ksgn,ktmin,last,limit,maxerr,neval,nres,nrmax,numrl2
  logical extrap,noext
  dimension alist(limit),blist(limit),elist(limit),iord(limit), &
   res3la(3),rlist(limit),rlist2(52)

  procedure(scalar_func) :: f

  correc = 0.0D+00
  erlarg = 0.0D+00
  ertest = 0.0D+00
  small = 0.0D+00
  epmach = epsilon ( epmach )
!
!  test on validity of parameters
!
  ier = 0
  neval = 0
  last = 0
  result = 0.0D+00
  abserr = 0.0D+00
  alist(1) = a
  blist(1) = b
  rlist(1) = 0.0D+00
  elist(1) = 0.0D+00

  if(epsabs.le.0.0D+00.and.epsrel.lt. max ( 0.5D+02*epmach,0.5d-28)) then
    ier = 6
    return
  end if
!
!  first approximation to the integral
!
  uflow = tiny ( uflow )
  oflow = huge ( oflow )
  ierro = 0
  call dqk21(f,a,b,result,abserr,defabs,resabs)
!
!  test on accuracy.
!
  dres =  abs ( result)
  errbnd =  max ( epsabs,epsrel*dres)
  last = 1
  rlist(1) = result
  elist(1) = abserr
  iord(1) = 1
  if(abserr.le.1.0D+02*epmach*defabs.and.abserr.gt.errbnd) ier = 2
  if(limit.eq.1) ier = 1
  if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs).or. &
    abserr.eq.0.0D+00) go to 140
!
!  initialization
!
  rlist2(1) = result
  errmax = abserr
  maxerr = 1
  area = result
  errsum = abserr
  abserr = oflow
  nrmax = 1
  nres = 0
  numrl2 = 2
  ktmin = 0
  extrap = .false.
  noext = .false.
  iroff1 = 0
  iroff2 = 0
  iroff3 = 0
  ksgn = -1
  if(dres.ge.(0.1D+01-0.5D+02*epmach)*defabs) ksgn = 1
!
!  main do-loop
!
  do 90 last = 2,limit
!
!  bisect the subinterval with the nrmax-th largest error estimate.
!
    a1 = alist(maxerr)
    b1 = 0.5D+00*(alist(maxerr)+blist(maxerr))
    a2 = b1
    b2 = blist(maxerr)
    erlast = errmax
    call dqk21(f,a1,b1,area1,error1,resabs,defab1)
    call dqk21(f,a2,b2,area2,error2,resabs,defab2)
!
!  improve previous approximations to integral
!  and error and test for accuracy.
!
    area12 = area1+area2
    erro12 = error1+error2
    errsum = errsum+erro12-errmax
    area = area+area12-rlist(maxerr)
    if(defab1.eq.error1.or.defab2.eq.error2) go to 15
    if( abs ( rlist(maxerr)-area12).gt.0.1D-04* abs ( area12) &
    .or.erro12.lt.0.99D+00*errmax) go to 10
    if(extrap) iroff2 = iroff2+1
    if(.not.extrap) iroff1 = iroff1+1
   10   if(last.gt.10.and.erro12.gt.errmax) iroff3 = iroff3+1
   15   rlist(maxerr) = area1
    rlist(last) = area2
    errbnd =  max ( epsabs,epsrel* abs ( area))
!
!  test for roundoff error and eventually set error flag.
!
    if(iroff1+iroff2.ge.10.or.iroff3.ge.20) ier = 2
    if(iroff2.ge.5) ierro = 3
!
!  set error flag in the case that the number of subintervals
!  equals limit.
!
    if(last.eq.limit) ier = 1
!
!  set error flag in the case of bad integrand behaviour
!  at a point of the integration range.
!
    if( max (  abs ( a1), abs ( b2)).le.(0.1D+01+0.1D+03*epmach)* &
    ( abs ( a2)+0.1D+04*uflow)) ier = 4
!
!  append the newly-created intervals to the list.
!
    if(error2.gt.error1) go to 20
    alist(last) = a2
    blist(maxerr) = b1
    blist(last) = b2
    elist(maxerr) = error1
    elist(last) = error2
    go to 30
   20   alist(maxerr) = a2
    alist(last) = a1
    blist(last) = b1
    rlist(maxerr) = area2
    rlist(last) = area1
    elist(maxerr) = error2
    elist(last) = error1
!
!  call dqpsrt to maintain the descending ordering
!  in the list of error estimates and select the subinterval
!  with nrmax-th largest error estimate (to be bisected next).
!
   30   call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax)
    if(errsum.le.errbnd) go to 115
    if(ier.ne.0) go to 100
    if(last.eq.2) go to 80
    if(noext) go to 90
    erlarg = erlarg-erlast
    if( abs ( b1-a1).gt.small) erlarg = erlarg+erro12
    if(extrap) go to 40
!
!  test whether the interval to be bisected next is the
!  smallest interval.
!
    if( abs ( blist(maxerr)-alist(maxerr)).gt.small) go to 90
    extrap = .true.
    nrmax = 2
   40   if(ierro.eq.3.or.erlarg.le.ertest) go to 60
!
!  the smallest interval has the largest error.
!  before bisecting decrease the sum of the errors over the
!  larger intervals (erlarg) and perform extrapolation.
!
    id = nrmax
    jupbnd = last
    if(last.gt.(2+limit/2)) jupbnd = limit+3-last
    do k = id,jupbnd
      maxerr = iord(nrmax)
      errmax = elist(maxerr)
      if( abs ( blist(maxerr)-alist(maxerr)).gt.small) go to 90
      nrmax = nrmax+1
    end do
!
!  perform extrapolation.
!
   60   numrl2 = numrl2+1
    rlist2(numrl2) = area
    call dqelg(numrl2,rlist2,reseps,abseps,res3la,nres)
    ktmin = ktmin+1
    if(ktmin.gt.5.and.abserr.lt.0.1D-02*errsum) ier = 5
    if(abseps.ge.abserr) go to 70
    ktmin = 0
    abserr = abseps
    result = reseps
    correc = erlarg
    ertest =  max ( epsabs,epsrel* abs ( reseps))
    if(abserr.le.ertest) go to 100
!
!  prepare bisection of the smallest interval.
!
   70   if(numrl2.eq.1) noext = .true.
    if(ier.eq.5) go to 100
    maxerr = iord(1)
    errmax = elist(maxerr)
    nrmax = 1
    extrap = .false.
    small = small*0.5D+00
    erlarg = errsum
    go to 90
   80   small =  abs ( b-a)*0.375D+00
    erlarg = errsum
    ertest = errbnd
    rlist2(2) = area
   90 continue
!
!  set final result and error estimate.
!
  100 if(abserr.eq.oflow) go to 115
  if(ier+ierro.eq.0) go to 110
  if(ierro.eq.3) abserr = abserr+correc
  if(ier.eq.0) ier = 3
  if(result.ne.0.0D+00.and.area.ne.0.0D+00) go to 105
  if(abserr.gt.errsum) go to 115
  if(area.eq.0.0D+00) go to 130
  go to 110
  105 if(abserr/ abs ( result).gt.errsum/ abs ( area)) go to 115
!
!  test on divergence.
!
  110 if(ksgn.eq.(-1).and. max (  abs ( result), abs ( area)).le. &
   defabs*0.1D-01) go to 130
  if(0.1D-01.gt.(result/area).or.(result/area).gt.0.1D+03 &
   .or.errsum.gt. abs ( area)) ier = 6
  go to 130
!
!  compute global integral sum.
!
  115 result = 0.0D+00
  do k = 1,last
     result = result+rlist(k)
  end do
  abserr = errsum
  130 if(ier.gt.2) ier = ier-1
  140 neval = 42*last-21

  return
end subroutine dqagse

subroutine dqelg ( n, epstab, result, abserr, res3la, nres )

!*****************************************************************************80
!
!! DQELG carries out the Epsilon extrapolation algorithm.
!
!  Modified:
!
!    11 September 2015
!
!  Author:
!
!    Robert Piessens, Elise de Doncker
!
!***purpose  the routine determines the limit of a given sequence of
!      approximations, by means of the epsilon algorithm of
!      p.wynn. an estimate of the absolute error is also given.
!      the condensed epsilon table is computed. only those
!      elements needed for the computation of the next diagonal
!      are preserved.
!
!  Parameters:
!
!        n      - integer ( kind = 4 )
!                 epstab(n) contains the new element in the
!                 first column of the epsilon table.
!
!        epstab - real ( kind = 8 )
!                 vector of dimension 52 containing the elements
!                 of the two lower diagonals of the triangular
!                 epsilon table. the elements are numbered
!                 starting at the right-hand corner of the
!                 triangle.
!
!        result - real ( kind = 8 )
!                 resulting approximation to the integral
!
!        abserr - real ( kind = 8 )
!                 estimate of the absolute error computed from
!                 result and the 3 previous results
!
!        res3la - real ( kind = 8 )
!                 vector of dimension 3 containing the last 3
!                 results
!
!        nres   - integer ( kind = 4 )
!                 number of calls to the routine
!                 (should be zero at first call)
!
!  Local Parameters:
!
!     e0     - the 4 elements on which the computation of a new
!     e1       element in the epsilon table is based
!     e2
!     e3                 e0
!                  e3    e1    new
!                        e2
!     newelm - number of elements to be computed in the new
!              diagonal
!     error  - error = abs(e1-e0)+abs(e2-e1)+abs(new-e2)
!     result - the element in the new diagonal with least value
!              of error
!
!     machine dependent constants
!
!     epmach is the largest relative spacing.
!     oflow is the largest positive magnitude.
!     limexp is the maximum number of elements the epsilon
!     table can contain. if this number is reached, the upper
!     diagonal of the epsilon table is deleted.
!
  implicit none

  real ( kind = 8 ) abserr,delta1,delta2,delta3, &
    epmach,epsinf,epstab,error,err1,err2,err3,e0,e1,e1abs,e2,e3, &
    oflow,res,result,res3la,ss,tol1,tol2,tol3
  integer ( kind = 4 ) i,ib,ib2,ie,indx,k1,k2,k3,limexp,n,newelm
  integer ( kind = 4 ) nres
  integer ( kind = 4 ) num
  dimension epstab(52),res3la(3)

  epmach = epsilon ( epmach )
  oflow = huge ( oflow )
  nres = nres+1
  abserr = oflow
  result = epstab(n)
  if(n.lt.3) go to 100
  limexp = 50
  epstab(n+2) = epstab(n)
  newelm = (n-1)/2
  epstab(n) = oflow
  num = n
  k1 = n

  do 40 i = 1,newelm

    k2 = k1-1
    k3 = k1-2
    res = epstab(k1+2)
    e0 = epstab(k3)
    e1 = epstab(k2)
    e2 = res
    e1abs =  abs ( e1)
    delta2 = e2-e1
    err2 =  abs ( delta2)
    tol2 =  max (  abs ( e2),e1abs)*epmach
    delta3 = e1 - e0
    err3 =  abs ( delta3)
    tol3 =  max ( e1abs, abs ( e0))*epmach
    if(err2.gt.tol2.or.err3.gt.tol3) go to 10
!
!  if e0, e1 and e2 are equal to machine accuracy, convergence is assumed.
!
    result = res
    abserr = err2+err3
    go to 100
   10   e3 = epstab(k1)
    epstab(k1) = e1
    delta1 = e1-e3
    err1 =  abs ( delta1)
    tol1 =  max ( e1abs, abs ( e3))*epmach
!
!  if two elements are very close to each other, omit
!  a part of the table by adjusting the value of n
!
    if(err1.le.tol1.or.err2.le.tol2.or.err3.le.tol3) go to 20
    ss = 0.1D+01/delta1+0.1D+01/delta2-0.1D+01/delta3
    epsinf =  abs ( ss*e1)
!
!  test to detect irregular behaviour in the table, and
!  eventually omit a part of the table adjusting the value
!  of n.
!
    if(epsinf.gt.0.1D-03) go to 30
   20   n = i+i-1
    go to 50
!
!  compute a new element and eventually adjust
!  the value of result.
!
   30   res = e1+0.1D+01/ss
    epstab(k1) = res
    k1 = k1-2
    error = err2 + abs ( res-e2 ) + err3

    if ( error .le. abserr ) then
      abserr = error
      result = res
    end if

   40 continue
!
!  shift the table.
!
   50 if(n.eq.limexp) n = 2*(limexp/2)-1
  ib = 1
  if((num/2)*2.eq.num) ib = 2
  ie = newelm+1
  do i=1,ie
    ib2 = ib+2
    epstab(ib) = epstab(ib2)
    ib = ib2
  end do
  if(num.eq.n) go to 80
  indx = num-n+1
  do i = 1,n
    epstab(i)= epstab(indx)
    indx = indx+1
  end do
   80 if(nres.ge.4) go to 90
  res3la(nres) = result
  abserr = oflow
  go to 100
!
!  compute error estimate
!
   90 abserr =  abs ( result-res3la(3))+ abs ( result-res3la(2)) &
    + abs ( result-res3la(1))
  res3la(1) = res3la(2)
  res3la(2) = res3la(3)
  res3la(3) = result
  100 continue

  abserr =  max ( abserr, 0.5D+01*epmach* abs ( result))

  return
end subroutine dqelg

subroutine dqk21(f,a,b,result,abserr,resabs,resasc)

!*****************************************************************************80
!
!! DQK21 carries out a 21 point Gauss-Kronrod quadrature rule.
!
!  Modified:
!
!    11 September 2015
!
!  Author:
!
!    Robert Piessens, Elise de Doncker
!
!***purpose  to compute i = integral of f over (a,b), with error
!                     estimate
!                 j = integral of abs(f) over (a,b)
!
!  Parameters:
!
!      on entry
!        f      - real ( kind = 8 )
!                 function subprogram defining the integrand
!                 function f(x). the actual name for f needs to be
!                 declared e x t e r n a l in the driver program.
!
!        a      - real ( kind = 8 )
!                 lower limit of integration
!
!        b      - real ( kind = 8 )
!                 upper limit of integration
!
!      on return
!        result - real ( kind = 8 )
!                 approximation to the integral i
!                 result is computed by applying the 21-point
!                 kronrod rule (resk) obtained by optimal addition
!                 of abscissae to the 10-point gauss rule (resg).
!
!        abserr - real ( kind = 8 )
!                 estimate of the modulus of the absolute error,
!                 which should not exceed abs(i-result)
!
!        resabs - real ( kind = 8 )
!                 approximation to the integral j
!
!        resasc - real ( kind = 8 )
!                 approximation to the integral of abs(f-i/(b-a))
!                 over (a,b)
!
!  Local Parameters:
!
!
!     the abscissae and weights are given for the interval (-1,1).
!     because of symmetry only the positive abscissae and their
!     corresponding weights are given.
!
!     xgk    - abscissae of the 21-point kronrod rule
!              xgk(2), xgk(4), ...  abscissae of the 10-point
!              gauss rule
!              xgk(1), xgk(3), ...  abscissae which are optimally
!              added to the 10-point gauss rule
!
!     wgk    - weights of the 21-point kronrod rule
!
!     wg     - weights of the 10-point gauss rule
!
!
! gauss quadrature weights and kronron quadrature abscissae and weights
! as evaluated with 80 decimal digit arithmetic by l. w. fullerton,
! bell labs, nov. 1981.
!
!     centr  - mid point of the interval
!     hlgth  - half-length of the interval
!     absc   - abscissa
!     fval*  - function value
!     resg   - result of the 10-point gauss formula
!     resk   - result of the 21-point kronrod formula
!     reskh  - approximation to the mean value of f over (a,b),
!              i.e. to i/(b-a)
!
!
!     machine dependent constants
!
!     epmach is the largest relative spacing.
!     uflow is the smallest positive magnitude.
!
  implicit none

  real ( kind = 8 ) a,absc,abserr,b,centr,dhlgth, &
    epmach,fc,fsum,fval1,fval2,fv1,fv2,hlgth,resabs,resasc, &
    resg,resk,reskh,result,uflow,wg,wgk,xgk
  integer ( kind = 4 ) j,jtw,jtwm1
  procedure(scalar_func) :: f
  dimension fv1(10),fv2(10),wg(5),wgk(11),xgk(11)

  data wg  (  1) / 0.066671344308688137593568809893332d0 /
  data wg  (  2) / 0.149451349150580593145776339657697d0 /
  data wg  (  3) / 0.219086362515982043995534934228163d0 /
  data wg  (  4) / 0.269266719309996355091226921569469d0 /
  data wg  (  5) / 0.295524224714752870173892994651338d0 /

  data xgk (  1) / 0.995657163025808080735527280689003d0 /
  data xgk (  2) / 0.973906528517171720077964012084452d0 /
  data xgk (  3) / 0.930157491355708226001207180059508d0 /
  data xgk (  4) / 0.865063366688984510732096688423493d0 /
  data xgk (  5) / 0.780817726586416897063717578345042d0 /
  data xgk (  6) / 0.679409568299024406234327365114874d0 /
  data xgk (  7) / 0.562757134668604683339000099272694d0 /
  data xgk (  8) / 0.433395394129247190799265943165784d0 /
  data xgk (  9) / 0.294392862701460198131126603103866d0 /
  data xgk ( 10) / 0.148874338981631210884826001129720d0 /
  data xgk ( 11) / 0.000000000000000000000000000000000d0 /

  data wgk (  1) / 0.011694638867371874278064396062192d0 /
  data wgk (  2) / 0.032558162307964727478818972459390d0 /
  data wgk (  3) / 0.054755896574351996031381300244580d0 /
  data wgk (  4) / 0.075039674810919952767043140916190d0 /
  data wgk (  5) / 0.093125454583697605535065465083366d0 /
  data wgk (  6) / 0.109387158802297641899210590325805d0 /
  data wgk (  7) / 0.123491976262065851077958109831074d0 /
  data wgk (  8) / 0.134709217311473325928054001771707d0 /
  data wgk (  9) / 0.142775938577060080797094273138717d0 /
  data wgk ( 10) / 0.147739104901338491374841515972068d0 /
  data wgk ( 11) / 0.149445554002916905664936468389821d0 /

  epmach = epsilon ( epmach )
  uflow = tiny ( uflow )
  centr = 0.5D+00*(a+b)
  hlgth = 0.5D+00*(b-a)
  dhlgth =  abs ( hlgth)
!
!  compute the 21-point kronrod approximation to
!  the integral, and estimate the absolute error.
!
  resg = 0.0D+00
  fc = f(centr)
  resk = wgk(11)*fc
  resabs =  abs ( resk)
  do j=1,5
    jtw = 2*j
    absc = hlgth*xgk(jtw)
    fval1 = f(centr-absc)
    fval2 = f(centr+absc)
    fv1(jtw) = fval1
    fv2(jtw) = fval2
    fsum = fval1+fval2
    resg = resg+wg(j)*fsum
    resk = resk+wgk(jtw)*fsum
    resabs = resabs+wgk(jtw)*( abs ( fval1)+ abs ( fval2))
  end do

  do j = 1,5
    jtwm1 = 2*j-1
    absc = hlgth*xgk(jtwm1)
    fval1 = f(centr-absc)
    fval2 = f(centr+absc)
    fv1(jtwm1) = fval1
    fv2(jtwm1) = fval2
    fsum = fval1+fval2
    resk = resk+wgk(jtwm1)*fsum
    resabs = resabs+wgk(jtwm1)*( abs ( fval1)+ abs ( fval2))
  end do

  reskh = resk*0.5D+00
  resasc = wgk(11)* abs ( fc-reskh)

  do j=1,10
    resasc = resasc+wgk(j)*( abs ( fv1(j)-reskh)+ abs ( fv2(j)-reskh))
  end do

  result = resk*hlgth
  resabs = resabs*dhlgth
  resasc = resasc*dhlgth
  abserr =  abs ( (resk-resg)*hlgth)
  if(resasc.ne.0.0D+00.and.abserr.ne.0.0D+00) &
    abserr = resasc*min(0.1D+01,(0.2D+03*abserr/resasc)**1.5D+00)
  if(resabs.gt.uflow/(0.5D+02*epmach)) abserr = max &
    ((epmach*0.5D+02)*resabs,abserr)

  return
end subroutine dqk21

subroutine dqpsrt ( limit, last, maxerr, ermax, elist, iord, nrmax )

!*****************************************************************************80
!
!! DQPSRT maintains the order of a list of local error estimates.
!
!  Modified:
!
!    11 September 2015
!
!  Author:
!
!    Robert Piessens, Elise de Doncker
!
!***purpose  this routine maintains the descending ordering in the
!      list of the local error estimated resulting from the
!      interval subdivision process. at each call two error
!      estimates are inserted using the sequential search
!      method, top-down for the largest error estimate and
!      bottom-up for the smallest error estimate.
!
!  Parameters:
!
!        limit  - integer ( kind = 4 )
!                 maximum number of error estimates the list
!                 can contain
!
!        last   - integer ( kind = 4 )
!                 number of error estimates currently in the list
!
!        maxerr - integer ( kind = 4 )
!                 maxerr points to the nrmax-th largest error
!                 estimate currently in the list
!
!        ermax  - real ( kind = 8 )
!                 nrmax-th largest error estimate
!                 ermax = elist(maxerr)
!
!        elist  - real ( kind = 8 )
!                 vector of dimension last containing
!                 the error estimates
!
!        iord   - integer ( kind = 4 )
!                 vector of dimension last, the first k elements
!                 of which contain pointers to the error
!                 estimates, such that
!                 elist(iord(1)),...,  elist(iord(k))
!                 form a decreasing sequence, with
!                 k = last if last.le.(limit/2+2), and
!                 k = limit+1-last otherwise
!
!        nrmax  - integer ( kind = 4 )
!                 maxerr = iord(nrmax)
!
  implicit none

  real ( kind = 8 ) elist,ermax,errmax,errmin
  integer ( kind = 4 ) i,ibeg,ido,iord,isucc,j,jbnd,jupbn,k,last
  integer ( kind = 4 ) limit
  integer ( kind = 4 ) maxerr
  integer ( kind = 4 ) nrmax
  dimension elist(last),iord(last)
!
!  check whether the list contains more than
!  two error estimates.
!
  if(last.gt.2) go to 10
  iord(1) = 1
  iord(2) = 2
  go to 90
!
!  this part of the routine is only executed if, due to a
!  difficult integrand, subdivision increased the error
!  estimate. in the normal case the insert procedure should
!  start after the nrmax-th largest error estimate.
!
   10 errmax = elist(maxerr)

  ido = nrmax-1
  do i = 1,ido
    isucc = iord(nrmax-1)
    if(errmax.le.elist(isucc)) go to 30
    iord(nrmax) = isucc
    nrmax = nrmax-1
  end do
!
!  compute the number of elements in the list to be maintained
!  in descending order. this number depends on the number of
!  subdivisions still allowed.
!
   30 jupbn = last
  if(last.gt.(limit/2+2)) jupbn = limit+3-last
  errmin = elist(last)
!
!  insert errmax by traversing the list top-down,
!  starting comparison from the element elist(iord(nrmax+1)).
!
  jbnd = jupbn-1
  ibeg = nrmax+1

  do i=ibeg,jbnd
    isucc = iord(i)
    if(errmax.ge.elist(isucc)) go to 60
    iord(i-1) = isucc
  end do

  iord(jbnd) = maxerr
  iord(jupbn) = last
  go to 90
!
!  insert errmin by traversing the list bottom-up.
!
   60 iord(i-1) = maxerr
  k = jbnd

  do j=i,jbnd
    isucc = iord(k)
    if(errmin.lt.elist(isucc)) go to 80
    iord(k+1) = isucc
    k = k-1
  end do

  iord(i) = last
  go to 90
   80 iord(k+1) = last
!
!     set maxerr and ermax.
!
   90 maxerr = iord(nrmax)
  ermax = elist(maxerr)

  return
end subroutine dqpsrt

end module quadpack


      subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa)
      integer n,ldr
      integer ipvt(n)
      double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa(n)
c     **********
c
c     subroutine qrsolv
c
c     given an m by n matrix a, an n by n diagonal matrix d,
c     and an m-vector b, the problem is to determine an x which
c     solves the system
c
c           a*x = b ,     d*x = 0 ,
c
c     in the least squares sense.
c
c     this subroutine completes the solution of the problem
c     if it is provided with the necessary information from the
c     qr factorization, with column pivoting, of a. that is, if
c     a*p = q*r, where p is a permutation matrix, q has orthogonal
c     columns, and r is an upper triangular matrix with diagonal
c     elements of nonincreasing magnitude, then qrsolv expects
c     the full upper triangle of r, the permutation matrix p,
c     and the first n components of (q transpose)*b. the system
c     a*x = b, d*x = 0, is then equivalent to
c
c                  t       t
c           r*z = q *b ,  p *d*p*z = 0 ,
c
c     where x = p*z. if this system does not have full rank,
c     then a least squares solution is obtained. on output qrsolv
c     also provides an upper triangular matrix s such that
c
c            t   t               t
c           p *(a *a + d*d)*p = s *s .
c
c     s is computed within qrsolv and may be of separate interest.
c
c     the subroutine statement is
c
c       subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa)
c
c     where
c
c       n is a positive integer input variable set to the order of r.
c
c       r is an n by n array. on input the full upper triangle
c         must contain the full upper triangle of the matrix r.
c         on output the full upper triangle is unaltered, and the
c         strict lower triangle contains the strict upper triangle
c         (transposed) of the upper triangular matrix s.
c
c       ldr is a positive integer input variable not less than n
c         which specifies the leading dimension of the array r.
c
c       ipvt is an integer input array of length n which defines the
c         permutation matrix p such that a*p = q*r. column j of p
c         is column ipvt(j) of the identity matrix.
c
c       diag is an input array of length n which must contain the
c         diagonal elements of the matrix d.
c
c       qtb is an input array of length n which must contain the first
c         n elements of the vector (q transpose)*b.
c
c       x is an output array of length n which contains the least
c         squares solution of the system a*x = b, d*x = 0.
c
c       sdiag is an output array of length n which contains the
c         diagonal elements of the upper triangular matrix s.
c
c       wa is a work array of length n.
c
c     subprograms called
c
c       fortran-supplied ... dabs,dsqrt
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,j,jp1,k,kp1,l,nsing
      double precision cos,cotan,p5,p25,qtbpj,sin,sum,tan,temp,zero
      data p5,p25,zero /5.0d-1,2.5d-1,0.0d0/
c
c     copy r and (q transpose)*b to preserve input and initialize s.
c     in particular, save the diagonal elements of r in x.
c
      do 20 j = 1, n
         do 10 i = j, n
            r(i,j) = r(j,i)
   10       continue
         x(j) = r(j,j)
         wa(j) = qtb(j)
   20    continue
c
c     eliminate the diagonal matrix d using a givens rotation.
c
      do 100 j = 1, n
c
c        prepare the row of d to be eliminated, locating the
c        diagonal element using p from the qr factorization.
c
         l = ipvt(j)
         if (diag(l) .eq. zero) go to 90
         do 30 k = j, n
            sdiag(k) = zero
   30       continue
         sdiag(j) = diag(l)
c
c        the transformations to eliminate the row of d
c        modify only a single element of (q transpose)*b
c        beyond the first n, which is initially zero.
c
         qtbpj = zero
         do 80 k = j, n
c
c           determine a givens rotation which eliminates the
c           appropriate element in the current row of d.
c
            if (sdiag(k) .eq. zero) go to 70
            if (dabs(r(k,k)) .ge. dabs(sdiag(k))) go to 40
               cotan = r(k,k)/sdiag(k)
               sin = p5/dsqrt(p25+p25*cotan**2)
               cos = sin*cotan
               go to 50
   40       continue
               tan = sdiag(k)/r(k,k)
               cos = p5/dsqrt(p25+p25*tan**2)
               sin = cos*tan
   50       continue
c
c           compute the modified diagonal element of r and
c           the modified element of ((q transpose)*b,0).
c
            r(k,k) = cos*r(k,k) + sin*sdiag(k)
            temp = cos*wa(k) + sin*qtbpj
            qtbpj = -sin*wa(k) + cos*qtbpj
            wa(k) = temp
c
c           accumulate the transformation in the row of s.
c
            kp1 = k + 1
            if (n .lt. kp1) go to 70
            do 60 i = kp1, n
               temp = cos*r(i,k) + sin*sdiag(i)
               sdiag(i) = -sin*r(i,k) + cos*sdiag(i)
               r(i,k) = temp
   60          continue
   70       continue
   80       continue
   90    continue
c
c        store the diagonal element of s and restore
c        the corresponding diagonal element of r.
c
         sdiag(j) = r(j,j)
         r(j,j) = x(j)
  100    continue
c
c     solve the triangular system for z. if the system is
c     singular, then obtain a least squares solution.
c
      nsing = n
      do 110 j = 1, n
         if (sdiag(j) .eq. zero .and. nsing .eq. n) nsing = j - 1
         if (nsing .lt. n) wa(j) = zero
  110    continue
      if (nsing .lt. 1) go to 150
      do 140 k = 1, nsing
         j = nsing - k + 1
         sum = zero
         jp1 = j + 1
         if (nsing .lt. jp1) go to 130
         do 120 i = jp1, nsing
            sum = sum + r(i,j)*wa(i)
  120       continue
  130    continue
         wa(j) = (wa(j) - sum)/sdiag(j)
  140    continue
  150 continue
c
c     permute the components of z back to components of x.
c
      do 160 j = 1, n
         l = ipvt(j)
         x(l) = wa(j)
  160    continue
      return
c
c     last card of subroutine qrsolv.
c
      end


      SUBROUTINE FRD2I (FL,NFREQ,NCORE,QHHL,SCR2,SCR1,SCR3,SCR4,NROW)
C
      INTEGER         QHHL,SCR1,SCR2,SCR3,SCR4,TRL(7),OUT
      DIMENSION       FL(1),MCB(7),NAME(2)
      CHARACTER       UFM*23
      COMMON /XMSSG / UFM
      COMMON /BLANK / BOV,Q,RM
      COMMON /CONDAS/ PI,TWOPI
      COMMON /SYSTEM/ ISYS,OUT,DUM(52),IPREC
      COMMON /UNPAKX/ IOUT,INN,NNN,INCR1
      COMMON /PACKX / ITI,ITO,II,NN,INCR
      COMMON /TYPE  / P(2),IWC(4)
      DATA    NAME  / 4HFRD2,4HI   /
      DATA    NHFRDI/ 4HFRDI/
C
      IBUF1 = NCORE - ISYS
      IBUF2 = IBUF1 - ISYS
      NROW  = 0
      INCR  = 1
      INCR1 = 1
      II    = 1
      INN   = 1
      MCB(1)= QHHL
      CALL RDTRL (MCB)
      IF (MCB(1) .LT. 0) GO TO 1000
      NROW  = MCB(3)
      NI    =(MCB(2)/MCB(3))*2
      NNN   = NROW
      NN    = NROW*NROW
      ITI   = 3
      ITO   = ITI
      IOUT  = ITI
      NWC   = IWC(ITI)
      ISCR  = SCR1
      NLOOP = 1
      INDX  = 0
      XM    = RM
      IF (RM .GE. 0.0) GO TO 5
      ISCR  = SCR2
      NLOOP = NFREQ
      INDX  = 1
    5 CALL MAKMCB (TRL,ISCR,NN,MCB(4),ITO)
C
C     MAKE INDEPENDENT FREQ LIST
C
      IPD   = 1
      NL    = 2*NFREQ
      N     = NFREQ + 1
      ICORE = IBUF1
      IPI   = IPD + NL
      DO 10 I = 1,NFREQ
      FL(NL) = FL(N-I)*TWOPI*BOV
      FL(NL-1) = 0.0
      NL = NL -2
   10 CONTINUE
C
C     MAKE INDEPENDENT FREQ LIST
C
      CALL OPEN  (*1000,QHHL,FL(IBUF2),0)
      CALL GOPEN (ISCR,FL(IBUF1),1)
      CALL READ  (*999,*999,QHHL,FL(IPI),-3,0,FLAG)
      CALL READ  (*999,*999,QHHL,N,1,0,FLAG)
      N = N + N
      IF (RM.GE.0.0 .OR. N.EQ.NI) GO TO 15
      WRITE  (OUT, 2000) UFM,N,NI
 2000 FORMAT (A23,', THE NUMBER OF (M,K) PAIRS SPECIFIED ON MKAEROX ',
     1       'CARDS (', I5, ') IS NOT EQUAL ', /5X,
     2       'TO THE NUMBER OF FREQUENCIES SPECIFIED (', I5, '),')
      CALL MESAGE (-37,0,NAME)
  15  NI = MIN0(NI,N)
      CALL READ (*999,*999,QHHL,FL(IPI),NI,1,FLAG)
      IF (RM .LT. 0.0) CALL CLOSE (QHHL, 1)
C
      DO 200 KKK = 1, NLOOP
      IF (RM .GE. 0.0) GO TO 20
      XM = FL(2*KKK)
      CALL GOPEN (QHHL,FL(IBUF2),0)
   20 CONTINUE
C
C     FOR RM.GE.0.0, FIND M CLOSEST TO XM
C     FOR RM.LT.0.0, FIND K CLOSEST TO XM
C
      ICP = IPI + NI
      RMI = 1.E20
      RMS = 0.0
      DO 30 I = 1,NI,2
      RMX = ABS(FL(IPI+I+INDX-1)-XM)
      RMI = AMIN1(RMI,RMX)
      IF (RMX .GT. RMI) GO TO 30
      RMS = FL(IPI+I+INDX-1)
   30 CONTINUE
      RMI = RMS
C
C     FOR RM.GE.0.0, SELECT ALL K'S ASSOCIATED WITH RMI
C     FOR RM.LT.0.0, SELECT THE K EQUAL TO RMI
C
      K = 0
      DO 100 I = 1,NI,2
      IF (FL(IPI+I+INDX-1) .EQ. RMI) GO TO 120
C
C     SKIP MATRIX
C
      CALL SKPREC (QHHL,NROW)
      GO TO 100
C
C     MAKE MATRIX INTO COLUMN
C
  120 FL(IPI+K+1) = FL(IPI+I)
      K  = K + 2
      JI = ICP
      N  = NROW*NWC
      DO 130 J = 1,NROW
      CALL UNPACK (*131,QHHL,FL(JI))
      GO TO 135
  131 CALL ZEROC (FL(JI),N)
  135 JI = JI + N
  130 CONTINUE
C
C     DIVIDE IMAG PART OF QHHL BY FREQUENCY
C
      JJ = ICP + 1
      KK = JI  - 1
      DO 132 J = JJ,KK,2
      FL(J) = FL(J)/FL(IPI+I)
  132 CONTINUE
      IF (RM .LT. 0.0) FL(IPI+I) = -10000.0
      CALL PACK (FL(ICP),ISCR,TRL)
      IF (RM .LT. 0.0) GO TO 150
  100 CONTINUE
  150 CALL CLOSE (QHHL,1)
      CALL CLOSE (ISCR,1)
  200 CONTINUE
C
      CALL WRTTRL (TRL)
      CALL BUG (NHFRDI,200,K ,1)
      CALL BUG (NHFRDI,200,NFREQ,1)
      CALL BUG (NHFRDI,200,FL(1),ICP)
      IF (RM .LT. 0.0) RETURN
C
C     SETUP TO CALL MINTRP
C
      NI   = K/2
      NOGO = 0
      NC   = NCORE - ICP
      CALL DMPFIL (-SCR1,FL(ICP),NC)
      IM   = 0
      IK   = 1
      CALL MINTRP (NI,FL(IPI),NFREQ,FL(IPD),-1,IM,IK,0.0,SCR1,SCR2,SCR3,
     1             SCR4,FL(ICP),NC,NOGO,IPREC)
      IF (NOGO .EQ. 1) GO TO 998
      CALL DMPFIL (-SCR2,FL(ICP),NC)
      RETURN
C
  998 WRITE  (OUT,9980) UFM
 9980 FORMAT (A23,' 2271, INTERPOLATION MATRIX IS SINGULAR')
      GO TO 9999
  999 CALL MESAGE (-3,QHHL,NAME)
 9999 CALL MESAGE (-61,0,NAME)
 1000 CALL CLOSE (QHHL,1)
      RETURN
      END


program test_spline

use spline_dlg
use netcdf
use check_mod

    real, allocatable :: x(:), y(:), x2(:), s(:)
    integer :: n, n2, i
    integer :: nc_id, n_id, x_id, y_id, s_id, x2_id, n2_id
    character(len=100) :: fName
    real, allocatable :: splines(:,:)

    n = 10
    n2 = 9

    allocate (x(n),y(n))
    allocate (x2(n2),s(n2))
    allocate ( splines(n,4) )

    x = (/ (i*2*3.14/(n-1),i=0,n-1) /)
    y = cos(x)
    x2 = x(1:n-1)+(x(2)-x(1))/2

    splines = spline ( x, y, 0.0, 0.0 )

    do i=1,n2
        s(i) = splines(i,1) &
            + splines(i,2)*(x2(i)-x(i)) &
            + splines(i,3)*(x2(i)-x(i))**2 &
            + splines(i,4)*(x2(i)-x(i))**3
    enddo

    write(*,*) x
    write(*,*) y
    write(*,*) s

    ! write value to file
    ! -------------------

    fName = 'test_spline.nc'
    call check ( nf90_create ( fName, nf90_clobber, nc_id ) )
    call check ( nf90_def_dim ( nc_id, "n", n, n_id ) )
    call check ( nf90_def_dim ( nc_id, "n2", n2, n2_id ) )

    call check ( nf90_def_var ( nc_id, "x", nf90_real, &
        (/n_id/), x_id ) )
    call check ( nf90_def_var ( nc_id, "y", nf90_real, &
        (/n_id/), y_id ) )
    call check ( nf90_def_var ( nc_id, "s", nf90_real, &
        (/n2_id/), s_id ) )
    call check ( nf90_def_var ( nc_id, "x2", nf90_real, &
        (/n2_id/), x2_id ) )

    call check ( nf90_enddef ( nc_id ) )

    call check ( nf90_put_var ( nc_id, x_id, x ) )
    call check ( nf90_put_var ( nc_id, y_id, y ) )
    call check ( nf90_put_var ( nc_id, s_id, s ) )
    call check ( nf90_put_var ( nc_id, x2_id, x2 ) )

    call check ( nf90_close ( nc_id ) )

end program test_spline


!========================================================================
!
!                          T o m o f a s t - x
!                        -----------------------
!
!           Authors: Vitaliy Ogarko, Jeremie Giraud, Roland Martin.
!
!               (c) 2021 The University of Western Australia.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

! --------------------------------------------------------------------------
! Program to calculate the first zeroes (root abscissas) of the first
! kind Bessel function of integer order N using the subroutine ROOTJ.
! --------------------------------------------------------------------------
! SAMPLE RUN:
!
! (Calculate the first 10 zeroes of 1st kind Bessel function of order 2).
!
! Zeroes of Bessel Function of order:  2
!
! Number of calculated zeroes: 10
!
! Table of root abcissas (5 items per line)
! 0.51356223D+01 0.84172442D+01 0.11619841D+02 0.14795952D+02 0.17959819D+02
! 0.21116997D+02 0.24270112D+02 0.27420574D+02 0.30569204D+02 0.33716520D+02
!
! Table of error codes (5 items per line)
!   0   0   0   0   0
!   0   0   0   0   0
!
! --------------------------------------------------------------------------
! Reference: From Numath Library By Tuan Dang Trong in Fortran 77
!            [BIBLI 18].
!
!                                  F90 Release 1.0 By J-P Moreau, Paris
!                                           (www.jpmoreau.fr)
!---------------------------------------------------------------------------
!PROGRAM TROOTJ
!
!REAL*8  JZ(10)
!INTEGER IE(10)
!
!  N=2
!  NR=10
!
!  CALL ROOTJ(N,NR,JZ,IE)
!
!  print *,' '
!  write(*,10) N
!  write(*,20) NR
!  print *,' '
!  print *,'Table of root abcissas (5 items per line)'
!  write(*,50) (JZ(i),i=1,NR)
!  print *,' '
!  print *,'Table of error codes (5 items per line)'
!  write(*,60) (IE(i),i=1,NR)
!  print *,' '
!
!  stop
!
!10 format(/' Zeroes of Bessel Function of order: ', I2)
!20 format(/' Number of calculated zeroes: ', I2)
!
!50 format(5D15.8)
!60 format(5I4)
!
!END

module trootj

implicit none

contains

      SUBROUTINE ROOTJ(N,NK,JZERO,IER)
! ----------------------------------------------------------------------
!     CALCULATE THE FIRST NK ZEROES OF BESSEL FUNCTION J(N,X)
!
!     INPUTS:
!       N    ORDER OF FUNCTION J (INTEGER >= 0)                  I*4
!       NK   NUMBER OF FIRST ZEROES  (INTEGER > 0)               I*4
!     OUTPUTS:
!       JZERO(NK)  TABLE OF FIRST ZEROES (ABCISSAS)              R*8
!       IER(NK)    TABLE OF ERROR CODES (MUST BE ZEROES)         I*4
!
!     REFERENCE :
!     ABRAMOWITZ M. & STEGUN IRENE A.
!     HANDBOOK OF MATHEMATICAL FUNCTIONS
! ----------------------------------------------------------------------
      INTEGER N,NK,IERROR,K,NITMX
      REAL(KIND=8) ZEROJ,B0,B1,B2,B3,B5,B7,T0,T1,T3,T5,T7,PI,FN,FK,  &
      C1,C2,C3,C4,C5,F1,F2,F3,TOL,ERRJ,JZERO(NK)
      INTEGER IER(NK)
      DATA PI/3.14159265358979D0/,TOL/1.D-8/,NITMX/10/
      DATA C1,C2,C3,C4,C5 /1.8557571D0,1.033150D0,.00397D0,.0908D0,.043D0/
      FN = FLOAT(N)

!     FIRST ZERO
      IF (N==0) THEN

        ZEROJ = C1+C2-C3-C4+C5
!       WRITE(*,'(1X,A,I5,E15.6)') 'K=1,N=0,ZEROJ',K,ZEROJ

        CALL  SECANT(N,NITMX,TOL,ZEROJ,IERROR)

        IER(1)=IERROR
        JZERO(1)=ZEROJ
      ELSE

        F1 = FN**(1.D0/3.D0)
        F2 = F1*F1*FN
        F3 = F1*FN*FN
        ZEROJ = FN+C1*F1+(C2/F1)-(C3/FN)-(C4/F2)+(C5/F3)
!       WRITE(*,'(1X,A,I5,E15.6)') 'K=1,NE.0,ZEROJ',K,ZEROJ
        CALL       SECANT(N,NITMX,TOL,ZEROJ,IERROR)
        IER(1)=IERROR
        JZERO(1)=ZEROJ

      endif
        T0 = 4.D0*FN*FN
        T1 = T0-1.D0
        T3 = 4.D0*T1*(7.D0*T0-31.D0)
        T5 = 32.D0*T1*((83.D0*T0-982.D0)*T0+3779.D0)
        T7 = 64.D0*T1*(((6949.D0*T0-153855.D0)*T0+1585743.D0)*T0  &
                      -6277237.D0)

!    OTHER ZEROES
      DO K = 2,NK
        JZERO(K) = 0.D0
        FK = FLOAT(K)

!    MAC MAHON'S SERIES FOR K>>N

        B0 = (FK+.5D0*FN-.25D0)*PI
        B1 = 8.D0*B0
        B2 = B1*B1
        B3 = 3.D0*B1*B2
        B5 = 5.D0*B3*B2
        B7 = 7.D0*B5*B2
        ZEROJ = B0-(T1/B1)-(T3/B3)-(T5/B5)-(T7/B7)

        ERRJ=ABS(BESSJ(N,ZEROJ))
!      WRITE(*,'(1X,A,2I5,2E15.6)') 'N,K,ZEROJ,ERRJ',N,K,ZEROJ,ERRJ

!    IMPROVE SOLUTION USING SUBROUTINE SECANT

        IF (ERRJ>TOL) CALL SECANT(N,NITMX,TOL,ZEROJ,IERROR)
        JZERO(K)=ZEROJ
        IER(K)=IERROR
      enddo
      RETURN
      END SUBROUTINE ROOTJ
! ----------------------------------------------------------------------
      SUBROUTINE SECANT(N,NITMX,TOL,ZEROJ,IER)
      INTEGER N,NITMX,IER,IT,NEV,NTRY
      REAL(KIND=8) TOL,ZEROJ,P0,P1,Q0,Q1,DP,P,C(2)
      DATA C/.95D0,.999D0/
      NTRY=1
      IER=0

    5 P0 = C(NTRY)*ZEROJ

      P1 = ZEROJ
      NEV = 2
      Q0 = BESSJ(N,P0)
      Q1 = BESSJ(N,P1)
!     WRITE(*,'(1X,A,I5,4E15.6)') 'NTRY,P0,Q0,P1,Q1',NTRY,P0,Q0,P1,Q1
      DO IT = 1,NITMX
        IF(Q1==Q0) GO TO 15
        P = P1-Q1*(P1-P0)/(Q1-Q0)
        DP = P-P1
!       WRITE(*,'(1X,A,I5,4E15.6)') 'IT,P,DP',IT,P,DP
        IF (IT==1) GO TO 10
        IF (ABS(DP)<TOL) GO TO 20

   10   NEV = NEV+1
        P0 = P1
        Q0 = Q1
        P1 = P
        Q1 = BESSJ(N,P1)
      enddo
   15 NTRY=NTRY+1
      IF(NTRY<=2) GO TO 5
      IER= NTRY
   20 ZEROJ = P
      END SUBROUTINE SECANT

! ----------------------------------------------------------------------
      FUNCTION BESSJ (N,X)

!     THIS FUNCTION RETURNS THE VALUE OF THE FIRST KIND BESSEL FUNCTION
!     OF ORDER N, INTEGER FOR ANY REAL X. WE USE HERE THE CLASSICAL
!     RECURRENT FORMULA, WHEN  X > N. FOR X < N, THE MILLER'S ALGORITHM
!     IS USED TO AVOID OVERFLOWS.
!     REFERENCE :
!     C.W.CLENSHAW, CHEBYSHEV SERIES FOR MATHEMATICAL FUNCTIONS,
!     MATHEMATICAL TABLES, VOL.5, 1962.

      INTEGER N,IACC,J,JSUM,M
      REAL(KIND=8) BIGNO,BIGNI
      PARAMETER (IACC = 40,BIGNO = 1.D10, BIGNI = 1.D-10)
      !REAL(KIND=8) X,BESSJ,BESSJ0,BESSJ1,TOX,BJM,BJ,BJP,SUM
      REAL(KIND=8) X,BESSJ,TOX,BJM,BJ,BJP,SUM
      IF (N==0) THEN
      BESSJ = BESSJ0(X)
      RETURN
      endif
      IF (N==1) THEN
      BESSJ = BESSJ1(X)
      RETURN
      endif
      IF (X==0.) THEN
      BESSJ = 0.
      RETURN
      endif
      TOX = 2./X
      IF (X>FLOAT(N)) THEN
      BJM = BESSJ0(X)
      BJ  = BESSJ1(X)
      DO 11 J = 1,N-1
      BJP = J*TOX*BJ-BJM
      BJM = BJ
      BJ  = BJP
   11 CONTINUE
      BESSJ = BJ
      ELSE
      M = 2*((N+INT(SQRT(FLOAT(IACC*N))))/2)
      BESSJ = 0.
      JSUM = 0
      SUM = 0.
      BJP = 0.
      BJ  = 1.
      DO 12 J = M,1,-1
      BJM = J*TOX*BJ-BJP
      BJP = BJ
      BJ  = BJM
      IF (ABS(BJ)>BIGNO) THEN
      BJ  = BJ*BIGNI
      BJP = BJP*BIGNI
      BESSJ = BESSJ*BIGNI
      SUM = SUM*BIGNI
      endif
      IF (JSUM/=0) SUM = SUM+BJ
      JSUM = 1-JSUM
      IF (J==N) BESSJ = BJP
   12 CONTINUE
      SUM = 2.*SUM-BJ
      BESSJ = BESSJ/SUM
      endif
      RETURN
      END FUNCTION BESSJ
! ----------------------------------------------------------------------
      FUNCTION BESSJ0 (X)

!     THIS FUNCTION RETURNS THE VALUE OF THE FIRST KIND BESSEL FUNCTION
!     OF ORDER 0 FOR ANY REAL X. WE USE HERE THE POLYNOMIAL APPROXIMATION
!     BY SERIES OF CHEBYSHEV POLYNOMIALS FOR 0<X<8 AND 0<8/X<1.
!     REFERENCES :
!     M.ABRAMOWITZ,I.A.STEGUN, HANDBOOK OF MATHEMATICAL FUNCTIONS, 1965.
!     C.W.CLENSHAW, NATIONAL PHYSICAL LABORATORY MATHEMATICAL TABLES,
!     VOL.5, 1962.

      REAL(KIND=8) X,BESSJ0,AX,FR,FS,Z,FP,FQ,XX
      REAL(KIND=8) Y,P1,P2,P3,P4,P5,R1,R2,R3,R4,R5,R6,Q1,Q2,Q3,Q4,Q5,S1,S2,S3,S4,S5,S6
      DATA P1,P2,P3,P4,P5 /1.D0,-.1098628627D-2,.2734510407D-4,  &
      -.2073370639D-5,.2093887211D-6 /
      DATA Q1,Q2,Q3,Q4,Q5 /-.1562499995D-1,.1430488765D-3,   &
      -.6911147651D-5,.7621095161D-6,-.9349451520D-7 /
      DATA R1,R2,R3,R4,R5,R6 /57568490574.D0,-13362590354.D0,    &
      651619640.7D0,-11214424.18D0,77392.33017D0,-184.9052456D0 /
      DATA S1,S2,S3,S4,S5,S6 /57568490411.D0,1029532985.D0,  &
      9494680.718D0,59272.64853D0,267.8532712D0,1.D0 /
      IF(X==0.D0) GO TO 1
      AX = ABS (X)
      IF (AX<8.) THEN
      Y = X*X
      FR = R1+Y*(R2+Y*(R3+Y*(R4+Y*(R5+Y*R6))))
      FS = S1+Y*(S2+Y*(S3+Y*(S4+Y*(S5+Y*S6))))
      BESSJ0 = FR/FS
      ELSE
      Z = 8./AX
      Y = Z*Z
      XX = AX-.785398164
      FP = P1+Y*(P2+Y*(P3+Y*(P4+Y*P5)))
      FQ = Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*Q5)))
      BESSJ0 = SQRT(.636619772/AX)*(FP*COS(XX)-Z*FQ*SIN(XX))
      endif
      RETURN
    1 BESSJ0 = 1.D0
      RETURN
      END FUNCTION BESSJ0
! ----------------------------------------------------------------------
      FUNCTION BESSJ1 (X)

!     THIS FUNCTION RETURNS THE VALUE OF THE FIRST KIND BESSEL FUNCTION
!     OF ORDER 0 FOR ANY REAL X. WE USE HERE THE POLYNOMIAL APPROXIMATION
!     BY SERIES OF CHEBYSHEV POLYNOMIALS FOR 0<X<8 AND 0<8/X<1.
!     REFERENCES :
!     M.ABRAMOWITZ,I.A.STEGUN, HANDBOOK OF MATHEMATICAL FUNCTIONS, 1965.
!     C.W.CLENSHAW, NATIONAL PHYSICAL LABORATORY MATHEMATICAL TABLES,
!     VOL.5, 1962.

      REAL(KIND=8) X,BESSJ1,AX,FR,FS,Z,FP,FQ,XX
      REAL(KIND=8) Y,P1,P2,P3,P4,P5,P6,R1,R2,R3,R4,R5,R6,Q1,Q2,Q3,Q4,Q5,S1,S2,S3,S4,S5,S6
      DATA P1,P2,P3,P4,P5 /1.D0,.183105D-2,-.3516396496D-4,  &
      .2457520174D-5,-.240337019D-6 /,P6 /.636619772D0 /
      DATA Q1,Q2,Q3,Q4,Q5 /.04687499995D0,-.2002690873D-3,   &
      .8449199096D-5,-.88228987D-6,.105787412D-6 /
      DATA R1,R2,R3,R4,R5,R6 /72362614232.D0,-7895059235.D0, &
      242396853.1D0,-2972611.439D0,15704.48260D0,-30.16036606D0 /
      DATA S1,S2,S3,S4,S5,S6 /144725228442.D0,2300535178.D0, &
      18583304.74D0,99447.43394D0,376.9991397D0,1.D0 /

      AX = ABS(X)
      IF (AX<8.) THEN
      Y = X*X
      FR = R1+Y*(R2+Y*(R3+Y*(R4+Y*(R5+Y*R6))))
      FS = S1+Y*(S2+Y*(S3+Y*(S4+Y*(S5+Y*S6))))
      BESSJ1 = X*(FR/FS)
      ELSE
      Z = 8./AX
      Y = Z*Z
      XX = AX-2.35619491
      FP = P1+Y*(P2+Y*(P3+Y*(P4+Y*P5)))
      FQ = Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*Q5)))
      BESSJ1 = SQRT(P6/AX)*(COS(XX)*FP-Z*SIN(XX)*FQ)*SIGN(S6,X)
      endif
      RETURN
      END FUNCTION BESSJ1

! ----------------------------------------------------------------------
!     Calculate modified Bessel function of order N=0 using polynomial approximation.
!     Handbook of Mathematical Functions by Milton Abramowitz and Irene Stegun, page 378.
!     F90 Release 1.2 By J-P Moreau, Paris.
      FUNCTION BESSI0(X)
      IMPLICIT NONE
      REAL(KIND=8) X,BESSI0,Y,P1,P2,P3,P4,P5,P6,P7,  &
      Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9,AX,BX
      DATA P1,P2,P3,P4,P5,P6,P7/1.D0,3.5156229D0,3.0899424D0,1.2067492D0,  &
      0.2659732D0,0.360768D-1,0.45813D-2/
      DATA Q1,Q2,Q3,Q4,Q5,Q6,Q7,Q8,Q9/0.39894228D0,0.1328592D-1, &
      0.225319D-2,-0.157565D-2,0.916281D-2,-0.2057706D-1,  &
      0.2635537D-1,-0.1647633D-1,0.392377D-2/
      IF(ABS(X)<3.75D0) THEN
      Y=(X/3.75D0)**2
      BESSI0=P1+Y*(P2+Y*(P3+Y*(P4+Y*(P5+Y*(P6+Y*P7)))))
      ELSE
      AX=ABS(X)
      Y=3.75D0/AX
      BX=EXP(AX)/SQRT(AX)
      AX=Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*(Q5+Y*(Q6+Y*(Q7+Y*(Q8+Y*Q9)))))))
      BESSI0=AX*BX
      endif
      RETURN
      END FUNCTION BESSI0

end module trootj


! { dg-do compile }
! Testcase from PR 17713
module fit_functions
  implicit none
contains
  subroutine gauss( x, a, y, dy, ma )
    double precision, intent(in)     :: x
    double precision, intent(in)     :: a(:)
    double precision, intent(out)    :: y
    double precision, intent(out)    :: dy(:)
    integer,          intent(in)     :: ma
  end subroutine gauss
end module fit_functions

subroutine mrqcof( x, y, sig, ndata, a, ia, ma )
  use fit_functions

  implicit none
  double precision, intent(in)   :: x(:), y(:), sig(:)
  integer,   intent(in)          :: ndata
  double precision, intent(in)   :: a(:)
  integer,   intent(in)          :: ia(:), ma

  integer                           i
  double precision                  yan, dyda(ma)

  do i = 1, ndata
     call gauss( x(i), a, yan, dyda, ma )
  end do
end subroutine mrqcof


module n_bodies
    use integrators
    implicit none
    contains

    function adjust_timestep(dt, err, q, t_tot)
        implicit none
        real(8), intent(in) :: dt, err, t_tot
        integer(8), intent(in) :: q
        real(8) :: adjust_timestep
        real(8) :: fac
!        real :: facmax=6., facmin=0.01
!        real :: fac
        fac = 0.38**(1. / (1. + q))
        adjust_timestep = dt * fac * err**(-1. / (1. + q))
!        print *, "Adjust timestep", adjust_timestep, dt, fac, err
!        if (adjust_timestep > facmax * dt) then
!            adjust_timestep = facmax * dt
!        else if (adjust_timestep < facmin * dt) then
!            adjust_timestep = facmin * dt
        if ((adjust_timestep / t_tot < 1e-12) .or. isnan(adjust_timestep)) then
            adjust_timestep = t_tot * 1e-12
        end if
    end function adjust_timestep

    function center_of_mass(n, masses, positions)
        implicit none
        integer(8), intent(in) :: n
        real(8), intent(in), dimension(n) :: masses
        real(8), intent(in), dimension(n, 3) :: positions
        real(8), dimension(3) :: center_of_mass
        integer(8) :: i
        center_of_mass = 0.
        do i=1, n
            center_of_mass(:) = center_of_mass(:) + masses(i) * positions(i, :)
        end do
    end function center_of_mass

    function average_vel(n, masses, velocities)
        implicit none
        integer(8), intent(in) :: n
        real(8), intent(in), dimension(n) :: masses
        real(8), intent(in), dimension(n, 3) :: velocities
        real(8), dimension(3) :: average_vel
        integer(8) :: i
        average_vel = 0.
        do i=1, n
            average_vel(:) = average_vel(:) + masses(i) * velocities(i, :)
        end do
    end function average_vel

    subroutine n_body_model(integrator, n, n_times, masses, i_pos, i_vel, &
                            t_tot, dt, g, update_com, times, positions, &
                            velocities, &
                            status)
        implicit none
        character(265), intent(in) :: integrator
        integer(8) :: n, n_times, n_times_internal
        real(8), dimension(n), intent(in) :: masses
        real(8), dimension(n, 3), intent(in) :: i_pos, i_vel
        real(8), dimension(n, 3) :: poses, vels, null_poses, null_vels
        real(8), dimension(n, 3) :: tmp_poses, tmp_vels, accels
        real(8), dimension(3) :: com, avv
        real(8), intent(in) :: t_tot, dt
        real(8), intent(in) :: g
        logical, intent(in) :: update_com
        real(8) :: t_now
        integer(8) :: t, i, j
        real(8), dimension(n_times + 1), intent(out) :: times
        ! shape n_steps, n, 3
        real(8), dimension(n_times + 1, n, 3), intent(out) :: positions, velocities
        character(256), intent(out) :: status
        status = "Ok"

        if (n_times < int(t_tot/dt)) then
            print *, "SizeError, n_times too small for t_tot/dt"
            status = "SizeError, n_times too small for t_tot/dt"
            stop
        else
            n_times_internal = floor(t_tot / dt)
        end if
!        allocate(times(n_steps))
!        allocate(positions(n_steps, n, 3))
!        allocate(velocities(n_steps, n, 3))
!
!
        ! Centers the system inputs
        if (update_com) then
            com(:) = center_of_mass(n, masses, i_pos)
            avv(:) = average_vel(n, masses, i_vel)
            do i=1, n
                poses(i, :) = i_pos(i, :) - com
                vels(i, :) = i_vel(i, :) - avv
            end do
        end if

        timeloop: do t=1, n_times_internal
!            print *, t
            times(t) = t_now
            do i=1, n
                positions(t, i, :) = poses(i, :)
!                print *, poses(i, :)
                velocities(t, i, :) = vels(i, :)
            end do
!             Run the integrator of choice for a timestep, using temporary
!             variables to avoid simultaneous IO for variables
            if (integrator(1:len("euler")) == "euler") then
                call euler_forward(n, masses, poses, vels, dt, g, tmp_poses, &
                        tmp_vels)
!                print *, poses(2, :), tmp_poses(2, :)
!                print *, vels(2, :), tmp_vels(2, :)
                do i=1, n
                    poses(i, :) = tmp_poses(i, :)
                    vels(i, :) = tmp_vels(i, :)
                end do
            else if (integrator(1:len("kdk")) == "kdk") then
                call kdk(n, masses, poses, vels, dt, g, tmp_poses, tmp_vels)
                poses = tmp_poses
                vels = tmp_vels
            else if (integrator(1:len("rk3")) == "rk3") then
                call rk3_classic(n, masses, poses, vels, dt, g, tmp_poses, tmp_vels)
                poses = tmp_poses
                vels = tmp_vels
            else if (integrator == "rk4") then
                call rkf45(n, masses, poses, vels, dt, g, tmp_poses, tmp_vels, &
                           null_poses, null_vels)
                poses = tmp_poses
                vels = tmp_vels
            else if (integrator == "rk5") then
                call rkf45(n, masses, poses, vels, dt, g, null_poses, null_vels, &
                        tmp_poses, tmp_vels)
                poses = tmp_poses
                vels = tmp_vels
            end if
            t_now = t_now + dt

!             Check validity of the integrator's calculation
            do i=1, n
                do j=1, 3
                    if (isnan(poses(i, j))) then
                        print *, "NAN encountered for position at", i, j
                        status = "NAN encountered for position"
                        exit timeloop
                    end if
                    if (isnan(vels(i, j))) then
                        print *, "NAN encountered for velocity at", i, j
                        status = "NAN encountered for velocity"
                        exit timeloop
                    end if
                end do
            end do
!
!            print *, vels(2, :)
            ! Recenters the system
            if (update_com) then
                com(:) = center_of_mass(n, masses, poses)
                avv(:) = average_vel(n, masses, vels)
                do i=1, n
                    poses(i, :) = poses(i, :) - com(:)
                    vels(i, :) = vels(i, :) - avv(:)
                end do
            end if

!            print *, vels(2, :)

        end do timeloop

    end subroutine n_body_model

    subroutine adaptive_n_body_model(integrator, n, n_times, masses, i_pos, &
                                     i_vel, t_tot, tolerance, dt_0, q, g, &
                                     update_com, times, positions, &
                                     velocities, status)
        implicit none
        character(265), intent(in) :: integrator
        integer(8) :: n, n_times, n_times_internal
        real(8), dimension(n), intent(in) :: masses
        real(8), dimension(n, 3), intent(in) :: i_pos, i_vel
        real(8), dimension(n, 3) :: poses, vels, high_poses, high_vels
        real(8), dimension(n, 3) :: low_poses, low_vels, accels
        real(8), dimension(3) :: com, avv
        real(8), intent(in) :: t_tot, tolerance, g, dt_0
        integer(8), intent(in) :: q
        logical, intent(in) :: update_com
        real(8) :: t_now, err_sum, dt
        integer(8) :: t, i, j
        real(8), dimension(n_times + 1), intent(out) :: times
        ! shape n_steps, n, 3
        real(8), dimension(n_times + 1, n, 3), intent(out) :: positions, velocities
        character(256), intent(out) :: status

        status = "Ok"
        dt = dt_0
        if (n_times < int(t_tot/dt)) then
            print *, "SizeRisk, n_times too small for t_tot/dt=", int(t_tot/dt)
            status = "SizeRisk, n_times too small for t_tot/dt="
        else
            n_times_internal = floor(t_tot / dt)
        end if
       ! allocate(times(n_steps))
       ! allocate(positions(n_steps, n, 3))
       ! allocate(velocities(n_steps, n, 3))
!
!
        ! Centers the system inputs
        if (update_com) then
            com(:) = center_of_mass(n, masses, i_pos)
            avv(:) = average_vel(n, masses, i_vel)
            do i=1, n
                poses(i, :) = i_pos(i, :) - com
                vels(i, :) = i_vel(i, :) - avv
            end do
        end if
!        print *, poses(2, :)
!        print *, "Looping for...", n_times_internal
        timeloop: do t=1, n_times_internal
       !     print *, t
            if (t_now > t_tot) then
                exit timeloop
            end if
            times(t) = t_now
            do i=1, n
                positions(t, i, :) = poses(i, :)
!                print *, poses(i, :), vels(i, :)
                velocities(t, i, :) = vels(i, :)
            end do
       !      Run the integrator of choice for a timestep, using temporary
       !      variables to avoid simultaneous IO for variables
            if (integrator(1:len("kdkrk3")) == "kdkrk3") then
                call kdkrk3(n, masses, poses, vels, dt, g, low_poses, low_vels, &
                            high_poses, high_vels)
                poses = high_poses
                vels = high_vels
            else if (integrator(1:len("rkf45")) == "rkf45") then
                call rkf45(n, masses, poses, vels, dt, g, low_poses, low_vels, &
                           high_poses, high_vels)
!                print *, low_poses(2, :), high_poses(2, :)
                do i=1, n
                    poses(i, :) = high_poses(i, :)
                    vels(i, :) = high_vels(i, :)
                end do
            end if
!
       !      Check validity of the integrator's calculation
            do i=1, n
                do j=1, 3
                    if (isnan(poses(i, j))) then
                        print *, "NAN encountered for position at", i, j
                        status = "NAN encountered for position"
                        exit timeloop
                    end if
                    if (isnan(vels(i, j))) then
                        print *, "NAN encountered for velocity at", i, j
                        status = "NAN encountered for velocity"
                        exit timeloop
                    end if
                end do
            end do

       !     print *, vels(2, :)
            ! Recenters the system
            if (update_com) then
                com(:) = center_of_mass(n, masses, poses)
                avv(:) = average_vel(n, masses, vels)
                do i=1, n
                    poses(i, :) = poses(i, :) - com(:)
                    vels(i, :) = vels(i, :) - avv(:)
                end do
            end if
!
       !     print *, vels(2, :)
            err_sum = 0.
            do i=1, n
                err_sum = err_sum + vec_mag(3, (high_poses - low_poses) &
                        / tolerance)
                err_sum = err_sum + vec_mag(3, (high_vels - low_vels) &
                        / tolerance)
            end do
            err_sum = err_sum / real(n * 3 * 2)**0.5
!            print *, tolerance
!
            dt = adjust_timestep(dt, err_sum, q, t_tot)
!            print *, dt
!
            t_now = t_now + dt
!
!
         end do timeloop

    end subroutine adaptive_n_body_model
end module n_bodies


program test_corr
    use stdlib_experimental_error, only: check
    use stdlib_experimental_kinds, only: sp, dp, int32, int64
    use stdlib_experimental_stats, only: corr
    use,intrinsic :: ieee_arithmetic, only : ieee_is_nan
    implicit none

    real(sp), parameter :: sptol = 1000 * epsilon(1._sp)
    real(dp), parameter :: dptol = 1000 * epsilon(1._dp)

    real(dp) :: d1(5) = [1.0_dp, 2.0_dp, 3.0_dp, 4.0_dp, 5.0_dp]
    real(dp) :: d(4, 3) = reshape([1._dp, 3._dp, 5._dp, 22._dp,&
                                   3._dp, 4._dp, 6._dp, 20._dp,&
                                   15._dp, 14._dp, 13._dp, 12._dp], [4, 3])

    complex(dp) :: cd1(5) = [ cmplx(0.57706_dp, 0.00000_dp, kind = dp),&
                            cmplx(0.00000_dp, 1.44065_dp, kind = dp),&
                            cmplx(1.26401_dp, 0.00000_dp, kind = dp),&
                            cmplx(0.00000_dp, 0.88833_dp, kind = dp),&
                            cmplx(1.14352_dp, 0.00000_dp, kind = dp)]
    complex(dp) :: ds(2,3) = reshape([ cmplx(1._dp, 0._dp, kind = dp),&
                            cmplx(0._dp, 2._dp, kind = dp),&
                            cmplx(3._dp, 0._dp, kind = dp),&
                            cmplx(0._dp, 4._dp, kind = dp),&
                            cmplx(5._dp, 0._dp, kind = dp),&
                            cmplx(0._dp, 6._dp, kind = dp)], [2, 3])

    call test_sp(real(d1, sp), real(d, sp))

    call test_dp(d1,d)

    call test_int32(int(d1, int32) ,int(d, int32))

    call test_int64(int(d1, int64) ,int(d, int64))

    call test_csp(cmplx(cd1, kind = sp), cmplx(ds, kind = sp))

    call test_cdp(cd1, ds)

contains

    subroutine test_sp(x, x2)
        real(sp), intent(in) :: x(:)
        real(sp), intent(in) :: x2(:, :)

        call check( abs(corr(x, 1) - 1._sp) < sptol&
            , 'sp check 1')
        call check( ieee_is_nan(corr(x, 1, .false.))&
            , 'sp check 2')
        call check( ieee_is_nan(corr(x, 1, x == 1.)), 'sp check 3')
        call check( abs(corr(x, 1, x < 5) - 1._sp) < sptol, 'sp check 4')
        call check( ieee_is_nan(corr(x, 1, x < -999)), 'sp check 5')

        call check( any(ieee_is_nan(corr(x2, 1, mask = .false.)))&
            , 'sp check 6')
        call check( any(ieee_is_nan(corr(x2, 2, mask = .false.)))&
            , 'sp check 7')

        call check( all( abs( corr(x2, 1) - reshape([&
            1._sp, 0.9994439103600_sp, -0.870544389237152_sp, 0.99944391036_sp,&
            1._sp, -0.86261576629742_sp, -0.87054438923715_sp,  -0.862615766297428_sp,&
            1._sp ]&
            ,[ size(x2, 2), size(x2, 2)])&
            ) < sptol)&
            , 'sp check 8')
        call check( all( abs( corr(x2, 2) - reshape([&
             1._sp, 0.998742137866914_sp,  0.999846989517886_sp, -0.998337488459582_sp,&
             0.998742137866914_sp, 1._sp, 0.999466429486246_sp, -0.99419162560192020_sp,&
             0.999846989517886_sp, 0.999466429486246_sp, 1._sp, -0.99717646495273815_sp,&
             -0.998337488459582_sp, -0.994191625601920_sp, -0.997176464952738_sp, 1._sp]&
            ,[ size(x2, 1), size(x2, 1)])&
            ) < sptol)&
            , 'sp check 9')

        call check( any(ieee_is_nan(corr(x2, 1, mask = x2 < 10)))&
            , 'sp check 10')
        call check( all( abs( corr(x2, 1, mask = x2 < 22) - reshape([&
              1._sp, 0.981980506061965_sp, -1._sp&
              ,0.981980506061965_sp, 1._sp, -0.862615766297428_sp&
              ,-1._sp, -0.862615766297428_sp, 1._sp]&
            ,[ size(x2, 2), size(x2, 2)])&
            ) < sptol)&
            , 'sp check 11')
        call check( all( abs( corr(x2, 2, mask = x2 < 22) - reshape([&
            1._sp, 0.998742137866914_sp, 0.999846989517886_sp, -1._sp&
            ,0.998742137866914_sp, 1._sp, 0.999466429486246_sp, -1._sp&
            ,0.999846989517886_sp, 0.999466429486246_sp, 1._sp, -1._sp&
            ,-1._sp, -1._sp, -1._sp, 1._sp]&
            ,[ size(x2, 1), size(x2, 1)])&
            ) < sptol)&
            , 'sp check 12')

        call check( all(abs(corr(x2, 1, mask = x2 < 1000) - corr(x2, 1))&
            < sptol)&
            , 'sp check 13')

        call check( all(abs(corr(x2, 2, mask = x2 < 1000) - corr(x2, 2))&
            < sptol)&
            , 'sp check 14')

    end subroutine test_sp

    subroutine test_dp(x, x2)
        real(dp), intent(in) :: x(:)
        real(dp), intent(in) :: x2(:, :)

        call check( abs(corr(x, 1) - 1._dp) < dptol&
            , 'dp check 1')
        call check( ieee_is_nan(corr(x, 1, .false.))&
            , 'dp check 2')
        call check( ieee_is_nan(corr(x, 1, x == 1.)), 'dp check 3')
        call check( abs(corr(x, 1, x < 5) - 1._dp) < dptol, 'dp check 4')
        call check( ieee_is_nan(corr(x, 1, x < -999)), 'dp check 5')

        call check( any(ieee_is_nan(corr(x2, 1, mask = .false.)))&
            , 'dp check 6')
        call check( any(ieee_is_nan(corr(x2, 2, mask = .false.)))&
            , 'dp check 7')

        call check( all( abs( corr(x2, 1) - reshape([&
            1._dp, 0.9994439103600_dp, -0.870544389237152_dp, 0.99944391036_dp,&
            1._dp, -0.86261576629742_dp, -0.87054438923715_dp,  -0.862615766297428_dp,&
            1._dp ]&
            ,[ size(x2, 2), size(x2, 2)])&
            ) < dptol)&
            , 'dp check 8')
        call check( all( abs( corr(x2, 2) - reshape([&
             1._dp, 0.998742137866914_dp,  0.999846989517886_dp, -0.998337488459582_dp,&
             0.998742137866914_dp, 1._dp, 0.999466429486246_dp, -0.99419162560192020_dp,&
             0.999846989517886_dp, 0.999466429486246_dp, 1._dp, -0.99717646495273815_dp,&
             -0.998337488459582_dp, -0.994191625601920_dp, -0.997176464952738_dp, 1._dp]&
            ,[ size(x2, 1), size(x2, 1)])&
            ) < dptol)&
            , 'dp check 9')

        call check( any(ieee_is_nan(corr(x2, 1, mask = x2 < 10)))&
            , 'dp check 10')
        call check( all( abs( corr(x2, 1, mask = x2 < 22) - reshape([&
              1._dp, 0.981980506061965_dp, -1._dp&
              ,0.981980506061965_dp, 1._dp, -0.862615766297428_dp&
              ,-1._dp, -0.862615766297428_dp, 1._dp]&
            ,[ size(x2, 2), size(x2, 2)])&
            ) < dptol)&
            , 'dp check 11')
        call check( all( abs( corr(x2, 2, mask = x2 < 22) - reshape([&
            1._dp, 0.998742137866914_dp, 0.999846989517886_dp, -1._dp&
            ,0.998742137866914_dp, 1._dp, 0.999466429486246_dp, -1._dp&
            ,0.999846989517886_dp, 0.999466429486246_dp, 1._dp, -1._dp&
            ,-1._dp, -1._dp, -1._dp, 1._dp]&
            ,[ size(x2, 1), size(x2, 1)])&
            ) < dptol)&
            , 'dp check 12')

        call check( all(abs(corr(x2, 1, mask = x2 < 1000) - corr(x2, 1))&
            < dptol)&
            , 'dp check 13')

        call check( all(abs(corr(x2, 2, mask = x2 < 1000) - corr(x2, 2))&
            < dptol)&
            , 'dp check 14')

    end subroutine test_dp

    subroutine test_int32(x, x2)
        integer(int32), intent(in) :: x(:)
        integer(int32), intent(in) :: x2(:, :)

        call check( abs(corr(x, 1) - 1._dp) < dptol&
            , 'int32 check 1')
        call check( ieee_is_nan(corr(x, 1, .false.))&
            , 'int32 check 2')
        call check( ieee_is_nan(corr(x, 1, x == 1.)), 'int32 check 3')
        call check( abs(corr(x, 1, x < 5) - 1._dp) < dptol, 'int32 check 4')
        call check( ieee_is_nan(corr(x, 1, x < -999)), 'int32 check 5')

        call check( any(ieee_is_nan(corr(x2, 1, mask = .false.)))&
            , 'int32 check 6')
        call check( any(ieee_is_nan(corr(x2, 2, mask = .false.)))&
            , 'int32 check 7')

        call check( all( abs( corr(x2, 1) - reshape([&
            1._dp, 0.9994439103600_dp, -0.870544389237152_dp, 0.99944391036_dp,&
            1._dp, -0.86261576629742_dp, -0.87054438923715_dp,  -0.862615766297428_dp,&
            1._dp ]&
            ,[ size(x2, 2), size(x2, 2)])&
            ) < dptol)&
            , 'int32 check 8')
        call check( all( abs( corr(x2, 2) - reshape([&
             1._dp, 0.998742137866914_dp,  0.999846989517886_dp, -0.998337488459582_dp,&
             0.998742137866914_dp, 1._dp, 0.999466429486246_dp, -0.99419162560192020_dp,&
             0.999846989517886_dp, 0.999466429486246_dp, 1._dp, -0.99717646495273815_dp,&
             -0.998337488459582_dp, -0.994191625601920_dp, -0.997176464952738_dp, 1._dp]&
            ,[ size(x2, 1), size(x2, 1)])&
            ) < dptol)&
            , 'int32 check 9')

        call check( any(ieee_is_nan(corr(x2, 1, mask = x2 < 10)))&
            , 'int32 check 10')
        call check( all( abs( corr(x2, 1, mask = x2 < 22) - reshape([&
              1._dp, 0.981980506061965_dp, -1._dp&
              ,0.981980506061965_dp, 1._dp, -0.862615766297428_dp&
              ,-1._dp, -0.862615766297428_dp, 1._dp]&
            ,[ size(x2, 2), size(x2, 2)])&
            ) < dptol)&
            , 'int32 check 11')
        call check( all( abs( corr(x2, 2, mask = x2 < 22) - reshape([&
            1._dp, 0.998742137866914_dp, 0.999846989517886_dp, -1._dp&
            ,0.998742137866914_dp, 1._dp, 0.999466429486246_dp, -1._dp&
            ,0.999846989517886_dp, 0.999466429486246_dp, 1._dp, -1._dp&
            ,-1._dp, -1._dp, -1._dp, 1._dp]&
            ,[ size(x2, 1), size(x2, 1)])&
            ) < dptol)&
            , 'int32 check 12')

        call check( all(abs(corr(x2, 1, mask = x2 < 1000) - corr(x2, 1))&
            < dptol)&
            , 'int32 check 13')

        call check( all(abs(corr(x2, 2, mask = x2 < 1000) - corr(x2, 2))&
            < dptol)&
            , 'int32 check 14')

    end subroutine test_int32

    subroutine test_int64(x, x2)
        integer(int64), intent(in) :: x(:)
        integer(int64), intent(in) :: x2(:, :)

        call check( abs(corr(x, 1) - 1._dp) < dptol&
            , 'int64 check 1')
        call check( ieee_is_nan(corr(x, 1, .false.))&
            , 'int64 check 2')
        call check( ieee_is_nan(corr(x, 1, x == 1.)), 'int64 check 3')
        call check( abs(corr(x, 1, x < 5) - 1._dp) < dptol, 'int64 check 4')
        call check( ieee_is_nan(corr(x, 1, x < -999)), 'int64 check 5')

        call check( any(ieee_is_nan(corr(x2, 1, mask = .false.)))&
            , 'int64 check 6')
        call check( any(ieee_is_nan(corr(x2, 2, mask = .false.)))&
            , 'int64 check 7')

        call check( all( abs( corr(x2, 1) - reshape([&
            1._dp, 0.9994439103600_dp, -0.870544389237152_dp, 0.99944391036_dp,&
            1._dp, -0.86261576629742_dp, -0.87054438923715_dp,  -0.862615766297428_dp,&
            1._dp ]&
            ,[ size(x2, 2), size(x2, 2)])&
            ) < dptol)&
            , 'int64 check 8')
        call check( all( abs( corr(x2, 2) - reshape([&
             1._dp, 0.998742137866914_dp,  0.999846989517886_dp, -0.998337488459582_dp,&
             0.998742137866914_dp, 1._dp, 0.999466429486246_dp, -0.99419162560192020_dp,&
             0.999846989517886_dp, 0.999466429486246_dp, 1._dp, -0.99717646495273815_dp,&
             -0.998337488459582_dp, -0.994191625601920_dp, -0.997176464952738_dp, 1._dp]&
            ,[ size(x2, 1), size(x2, 1)])&
            ) < dptol)&
            , 'int64 check 9')

        call check( any(ieee_is_nan(corr(x2, 1, mask = x2 < 10)))&
            , 'int64 check 10')
        call check( all( abs( corr(x2, 1, mask = x2 < 22) - reshape([&
              1._dp, 0.981980506061965_dp, -1._dp&
              ,0.981980506061965_dp, 1._dp, -0.862615766297428_dp&
              ,-1._dp, -0.862615766297428_dp, 1._dp]&
            ,[ size(x2, 2), size(x2, 2)])&
            ) < dptol)&
            , 'int64 check 11')
        call check( all( abs( corr(x2, 2, mask = x2 < 22) - reshape([&
            1._dp, 0.998742137866914_dp, 0.999846989517886_dp, -1._dp&
            ,0.998742137866914_dp, 1._dp, 0.999466429486246_dp, -1._dp&
            ,0.999846989517886_dp, 0.999466429486246_dp, 1._dp, -1._dp&
            ,-1._dp, -1._dp, -1._dp, 1._dp]&
            ,[ size(x2, 1), size(x2, 1)])&
            ) < dptol)&
            , 'int64 check 12')

        call check( all(abs(corr(x2, 1, mask = x2 < 1000) - corr(x2, 1))&
            < dptol)&
            , 'int64 check 13')

        call check( all(abs(corr(x2, 2, mask = x2 < 1000) - corr(x2, 2))&
            < dptol)&
            , 'int64 check 14')

    end subroutine test_int64

    subroutine test_csp(x, x2)
        complex(sp), intent(in) :: x(:)
        complex(sp), intent(in) :: x2(:, :)

        call check( abs(corr(x, dim=1) - 1._sp)  < sptol&
            , 'csp check 1')
        call check( abs(corr(x, 1, aimag(x) == 0) - 1._sp ) < sptol&
            , 'csp check 2')

        call check( ieee_is_nan(corr(x, 1, aimag(x) == -99 )) &
            , 'csp check 3')

        call check( ieee_is_nan(real(corr(x, 1, .false.)))&
            , 'csp check 4')

        call check( all( abs( corr(x2, 1) - reshape([&
               (1._sp,0._sp), (0.983869910099907_sp,-0.178885438199983_sp),&
               (0.973417168333576_sp,-0.229039333725547_sp),&
               (0.983869910099907_sp,0.178885438199983_sp), (1._sp,0._sp),&
               (0.998687663476588_sp,-0.051214751973158_sp),&
               (0.973417168333575_sp,0.229039333725547_sp),&
               (0.998687663476588_sp,0.0512147519731583_sp), (1._sp,0._sp) ]&
            ,[ size(x2, 2), size(x2, 2)])&
            ) < sptol)&
            , 'csp check 6')
        call check( all( abs( corr(x2, 2) - reshape([&
            (1._sp,0._sp), (0._sp,1._sp),&
            (0._sp,-1._sp), (1._sp,0._sp)]&
            ,[ size(x2, 1), size(x2, 1)])&
            ) < sptol)&
            , 'csp check 7')

        call check( all( abs( corr(x2, 2, mask = aimag(x2) < 6) - reshape([&
             (1._sp,0._sp), (0._sp,1._sp)&
             ,(0._sp,-1._sp), (1._sp,0._sp)]&
            ,[ size(x2, 1), size(x2, 1)])&
            ) < sptol)&
            , 'csp check 8')

        call check( all(abs(corr(x2, 1, mask = aimag(x2) < 1000) - corr(x2, 1))&
            < sptol)&
            , 'csp check 9')

        call check( all(abs(corr(x2, 2, mask = aimag(x2) < 1000) - corr(x2, 2))&
            < sptol)&
            , 'csp check 10')

    end subroutine test_csp

    subroutine test_cdp(x, x2)
        complex(dp), intent(in) :: x(:)
        complex(dp), intent(in) :: x2(:, :)

        call check( abs(corr(x, dim=1) - 1._dp)  < dptol&
            , 'cdp check 1')
        call check( abs(corr(x, 1, aimag(x) == 0) - 1._dp ) < dptol&
            , 'cdp check 2')

        call check( ieee_is_nan(corr(x, 1, aimag(x) == -99 )) &
            , 'cdp check 3')

        call check( ieee_is_nan(real(corr(x, 1, .false.)))&
            , 'cdp check 4')

        call check( all( abs( corr(x2, 1) - reshape([&
               (1._dp,0._dp), (0.983869910099907_dp,-0.178885438199983_dp),&
               (0.973417168333576_dp,-0.229039333725547_dp),&
               (0.983869910099907_dp,0.178885438199983_dp), (1._dp,0._dp),&
               (0.998687663476588_dp,-0.051214751973158_dp),&
               (0.973417168333575_dp,0.229039333725547_dp),&
               (0.998687663476588_dp,0.0512147519731583_dp), (1._dp,0._dp) ]&
            ,[ size(x2, 2), size(x2, 2)])&
            ) < dptol)&
            , 'cdp check 6')
        call check( all( abs( corr(x2, 2) - reshape([&
            (1._dp,0._dp), (0._dp,1._dp),&
            (0._dp,-1._dp), (1._dp,0._dp)]&
            ,[ size(x2, 1), size(x2, 1)])&
            ) < dptol)&
            , 'cdp check 7')

        call check( all( abs( corr(x2, 2, mask = aimag(x2) < 6) - reshape([&
             (1._dp,0._dp), (0._dp,1._dp)&
             ,(0._dp,-1._dp), (1._dp,0._dp)]&
            ,[ size(x2, 1), size(x2, 1)])&
            ) < dptol)&
            , 'cdp check 8')

        call check( all(abs(corr(x2, 1, mask = aimag(x2) < 1000) - corr(x2, 1))&
            < sptol)&
            , 'csp check 9')

        call check( all(abs(corr(x2, 2, mask = aimag(x2) < 1000) - corr(x2, 2))&
            < sptol)&
            , 'csp check 10')

    end subroutine test_cdp

end program test_corr