      subroutine gakmat(akmat0,dxsm00,nord,nrd1mx)
c
c     This subroutine computes the akmat0 matrix, which allows
c     calculation of estimates of derivatives from corresponding finite
c     differences. Note: this subroutine presumes that the diagonal
c     elements have been previously set to factorials and that the
c     lower triangle elements have previously been set to zero. These
c     parts of the matrix are invariant.
c
c     This routine can also be used to calculate the akmat1 matrix from
c     the dlxsm1 array, provided that in the calling sequence akmat1
c     is substituted for akmat0 and dlxsm1 for dxsm00. The akmat0 matrix
c     and the dxsm00 array are used with finite differences employed
c     to generate predictor functions, while akmat1 and dlxsm1 are used
c     are used with finite differences employed to generate corrector
c     functions.
c
c     This subroutine is called by:
c
c       EQ6/path.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c
c     Principal output:
c
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer nrd1mx
c
      integer nord
c
      real*8 akmat0(nrd1mx,nrd1mx),dxsm00(nrd1mx)
c
c----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer i,im1,ip1,j,jm1
c
c----------------------------------------------------------------------
c
      if (nord .ge. 2) then
c
        i = 1
        ip1 = i + 1
        do j = ip1,nord
          jm1 = j - 1
          akmat0(i,j) = akmat0(i,jm1)*dxsm00(jm1)
        enddo
c
        do i = 2,nord - 1
          ip1 = i + 1
          im1 = i - 1
          do j = ip1,nord
            jm1 = j - 1
            akmat0(i,j) = akmat0(i,jm1)*dxsm00(jm1) + akmat0(im1,jm1)*i
          enddo
        enddo
      endif
c
      end


!=======================================================================
!
!   S E R I A L   R A N D O M   N U M B E R   G E N E R A T O R
!
!=======================================================================
! Here's how to use these functions:
!       Initialization: call Rans( N, StartVal, Seeds )
! This returns an array of N seeds;
! the returned seeds have values that partition the basic
! ranf cycle of 2**46 pseudorandom reals in [0,1] into independent sub-
! sequences. The second argument, StartVal, can be a cycle-starting seed
! for the full-period generator; if it is zero, a special seed will be
! used that produces statistically desirable behavior.
!       Use: call Ranf( Seed, RandNum )
! This returns a pseudorandom real and a seed to be passed back in the
! next invocation. The returned seed carries the state normally hidden
! in imperative generators.
!=======================================================================
module random
  integer,parameter :: IRandNumSize = 4, IBinarySize = 48
  integer,parameter :: Mod4096DigitSize = 12
  integer,parameter :: IZero = 0
  integer,parameter :: NPoissonLimit = 10

  integer,dimension( IRandNumSize ) :: &
       & Multiplier = (/373, 3707, 1442, 647/)
  integer,dimension( IRandNumSize ) :: &
       & DefaultSeed = (/ 3281, 4041, 595, 2376 /)
  real(kind=8),dimension( IRandNumSize ) :: &
       & Divisor = (/281474976710656.0,68719476736.0,16777216.0,4096.0/)

  integer :: IGauss = 0
  real(kind=8) :: GaussBak = 0.0d0

contains
  !=======================================================================
  subroutine ranf( Seed, RandNum )
    implicit none
    integer,dimension( IRandNumSize ) :: Seed
    real(kind=8) :: RandNum

    integer,dimension( IRandNumSize ) :: OutSeed

    RandNum = float( Seed( 4 ) ) / Divisor( 4 ) + &
         &    float( Seed( 3 ) ) / Divisor( 3 ) + &
         &    float( Seed( 2 ) ) / Divisor( 2 ) + &
         &    float( Seed( 1 ) ) / Divisor( 1 )

    call ranfmodmult( Multiplier, Seed, OutSeed )

    Seed = OutSeed

    return
  end subroutine ranf
  !=======================================================================

  !=======================================================================
  subroutine poissdev( Seed, AverNum , PoissNum)
    implicit none
    integer,dimension( IRandNumSize ) :: Seed
    real(kind=8) :: AverNum
    integer :: PoissNum

    real(kind=8) :: Norm, Repar, Proba
    real(kind=8) :: RandNum, GaussNum

    if(AverNum <= DBLE(NPoissonLimit)) then
       Norm=exp(-AverNum)
       Repar=1.0d0
       PoissNum=0
       Proba=1.0d0
       call ranf(Seed,RandNum)
       do while(Repar*Norm <= RandNum .and. PoissNum <= 10*NPoissonLimit )
          PoissNum=PoissNum+1
          Proba=Proba*AverNum/PoissNum
          Repar=Repar+Proba
       end do
    else
       call gaussdev(Seed,GaussNum)
       GaussNum=GaussNum*sqrt(AverNum)-0.5+AverNum
       if(GaussNum<=0.0d0)GaussNum=0.0d0
       PoissNum=nint(GaussNum)
    endif

    return
  end subroutine poissdev
  !=======================================================================

  !=======================================================================
  subroutine gaussdev( Seed, GaussNum )
    implicit none
    integer,dimension( IRandNumSize ) :: Seed
    real(kind=8) :: GaussNum

    real(kind=8) :: fac,rsq,v1,v2

    if (IGauss.eq.IZero) then
       rsq=0.0d0
       do while (rsq.ge.1.0d0.or.rsq.le.0.0d0)
          call ranf(Seed,v1)
          call ranf(Seed,v2)
          v1=2.0d0*v1-1.0d0
          v2=2.0d0*v2-1.0d0
          rsq=v1**2+v2**2
       end do
       fac=sqrt(-2.0d0*log(rsq)/rsq)
       GaussBak=v1*fac
       GaussNum=v2*fac
       IGauss=1
    else
       GaussNum=GaussBak
       IGauss=0
    endif
    return
  END subroutine gaussdev
  !=======================================================================

  !=======================================================================
  subroutine rans( N, StartVal, SeedArray )
    implicit none
    integer :: N
    integer :: StartVal
    integer,dimension( 1, IRandNumSize ) :: SeedArray

    integer,dimension( IRandNumSize ) :: atothek
    integer,dimension( IRandNumSize ) :: K
    integer,dimension( IRandNumSize ) :: InSeed
    integer,dimension( IRandNumSize ) :: OutSeed
    integer,dimension( IBinarySize )  :: KBinary

    integer :: I

    if( StartVal .eq. IZero ) then
       SeedArray( 1, 1 ) = DefaultSeed( 1 )
       SeedArray( 1, 2 ) = DefaultSeed( 2 )
       SeedArray( 1, 3 ) = DefaultSeed( 3 )
       SeedArray( 1, 4 ) = DefaultSeed( 4 )
    else
       SeedArray( 1, 1 ) = abs( StartVal )
       SeedArray( 1, 2 ) = IZero
       SeedArray( 1, 3 ) = IZero
       SeedArray( 1, 4 ) = IZero
    endif

    if( N .eq. 1 ) then
       atothek( 1 ) = Multiplier( 1 )
       atothek( 2 ) = Multiplier( 2 )
       atothek( 3 ) = Multiplier( 3 )
       atothek( 4 ) = Multiplier( 4 )
    else
       call ranfk( N, K )
       call ranfkbinary( K, KBinary )
       call ranfatok( Multiplier, KBinary, atothek )
       do I = 2, N
          InSeed( 1 ) = SeedArray( I-1, 1 )
          InSeed( 2 ) = SeedArray( I-1, 2 )
          InSeed( 3 ) = SeedArray( I-1, 3 )
          InSeed( 4 ) = SeedArray( I-1, 4 )
          call ranfmodmult( InSeed, atothek, OutSeed )
          SeedArray( I, 1 ) = OutSeed( 1 )
          SeedArray( I, 2 ) = OutSeed( 2 )
          SeedArray( I, 3 ) = OutSeed( 3 )
          SeedArray( I, 4 ) = OutSeed( 4 )
       end do
    endif

    return
  end subroutine rans
  !=======================================================================

  !=======================================================================
  subroutine ranfatok( a, Kbinary, atothek )
    implicit none
    integer,dimension( IRandNumSize ) :: a
    integer,dimension( IBinarySize )  :: KBinary
    integer,dimension( IRandNumSize ) :: atothek

    integer,dimension( IRandNumSize ) :: asubi

    integer :: I
    asubi( 1 ) = a( 1 )
    asubi( 2 ) = a( 2 )
    asubi( 3 ) = a( 3 )
    asubi( 4 ) = a( 4 )

    atothek( 1 ) = 1
    atothek( 2 ) = IZero
    atothek( 3 ) = IZero
    atothek( 4 ) = IZero

    do I = 1, 45
       if( KBinary( I ) .ne. IZero ) then
          call ranfmodmult( atothek, asubi, atothek )
       endif
       call ranfmodmult( asubi, asubi, asubi )
    end do

    return
  end subroutine ranfatok
  !=======================================================================

  !=======================================================================
  subroutine ranfk( N, K )
    implicit none
    integer :: N
    integer, dimension( IRandNumSize ) :: K

    integer :: nn, r4, r3, r2, q4, q3, q2, q1

    nn = N + iranfeven( N )

    q4 = 1024 / nn
    r4 = 1024 - (nn * q4)
    q3 = (r4 * 4096) / nn
    r3 = (r4 * 4096) - (nn * q3)
    q2 = (r3 * 4096) / nn
    r2 = (r3 * 4096) - (nn * q2)
    q1 = (r2 * 4096) / nn

    K( 1 ) = q1
    K( 2 ) = q2
    K( 3 ) = q3
    K( 4 ) = q4

    return
  end subroutine ranfk
  !=======================================================================

  !=======================================================================
  subroutine ranfkbinary( K, KBinary )
    implicit none
    integer, dimension( IRandNumSize ) :: K
    integer, dimension( IBinarySize ) ::  KBinary

    integer, dimension( Mod4096DigitSize ) :: Bits
    integer X, I, J

    do I = 1, 4
       X = K( I ) / 2
       Bits( 1 ) = iranfodd( K( I ) )
       do J = 2, Mod4096DigitSize
          Bits( J ) = iranfodd( X )
          X = X / 2
       end do
       do J = 1, Mod4096DigitSize
          KBinary( (I-1)*Mod4096DigitSize + J ) = Bits( J )
       end do
    end do

    return
  end subroutine ranfkbinary
  !=======================================================================

  !=======================================================================
  subroutine ranfmodmult( A, B, C )
    implicit none
    integer, dimension( IRandNumSize ) :: A, B, C

    integer :: j1, j2, j3, j4, k1, k2, k3, k4

    j1 = A( 1 ) * B( 1 )
    j2 = A( 1 ) * B( 2 ) + A( 2 ) * B( 1 )
    j3 = A( 1 ) * B( 3 ) + A( 2 ) * B( 2 ) + A( 3 ) * B( 1 )
    j4 = A( 1 ) * B( 4 ) + A( 2 ) * B( 3 ) + A( 3 ) * B( 2 ) + A( 4 ) * B( 1 )

    k1 = j1
    k2 = j2 + k1 / 4096
    k3 = j3 + k2 / 4096
    k4 = j4 + k3 / 4096

    C( 1 ) = mod( k1, 4096 )
    C( 2 ) = mod( k2, 4096 )
    C( 3 ) = mod( k3, 4096 )
    C( 4 ) = mod( k4, 4096 )

    return
  end subroutine ranfmodmult
  !=======================================================================

  !=======================================================================
  function iranfodd( N )
    integer N
    if( mod( N, 2 ) .eq. 0 ) then
       iranfodd = 0
    else
       iranfodd = 1
    endif

    return
  end function iranfodd
  !=======================================================================
  !=======================================================================
  function iranfeven( N )
    integer N
    if( mod( N, 2 ) .eq. 0 ) then
       iranfeven = 1
    else
       iranfeven = 0
    endif
    return
  end function iranfeven
  !=======================================================================

end module random


! ***
! Couplage au plasma
! ***
MODULE aloha_function

      Use aloha_constants
      Use airy_functions_complex_double, Only: airy_ai
      ! TODO : la librairie utilisee ne permet que de calculer Airy Bi en reel !
      ! Il faudra trouver de quoi calculer Bi pour des valeurs complexes.
      Use airy_functions_real_double, Only: airy_bi

!       ! Equivalent NAG F90
!       Use nag_airy_fun, Only: nag_airy_ai

      implicit none

CONTAINS

!     !
!     !+ Classe les modes TM
!     !
!     function kc_e(Nmax,p,a,b,me)
!
!         use aloha_config, only : Nmhm, Nmem
!
!         ! input arguments
!         integer, intent(in)       :: Nmax, p, me(:,:)
!         real(kind=wp), intent(in) :: a, b(:)
!         real(kind=wp)             :: kc_e(Nmax,Nmax)
!         ! working variables
!         integer                   :: i,m,n
!         real(kind=wp)             :: mn
!
!         i=1
!         mn=Nmem/Nmhm
!
!         ! on ne prend que les TM avec m identique au m du TE
!             Do m=1,Nmhm
!         !         Do 110 n=m,(m+IDNINT(mn)-1)
!                 ! En multimode le n peut etre < a m car "a" augmente Ez/Ey#a/b.n/m
!                 Do n=1,Nint(mn)
!                     kc_e(i)=sqrt(m**2*b(p)/a+n**2*a/b(p))*PI/sqrt(a*b(p))
!                     me(1,i)=m
!                     me(2,i)=n
!                     i=i+1
!                 end do
!             end do
!         !      ri=i-1
!
!     end function

!     ! ***
!     ! Fonction calculant la racine de l'impedance carcteristique du mode h
!     ! ***
!     function sqrt_Zc_h(p,a,b,Nmh)
!         use aloha_config, only : k0,Nmax
!
!         implicit none
!
!         ! input arguments
!         integer, intent(in)       :: p, Nmh
!         real(kind=wp), intent(in) :: a, b(:)
!         ! result
!         complex(kind=wp)          :: sqrt_Zc_h(Nmh,Nmh)
!
!         ! working variables
!         integer                   :: i, mh(2,Nmh*Nmh)
!         real(kind=wp)             :: kch(Nmh*Nmh)
!         complex(kind=wp)          :: RZh(Nmh),RYh(Nmh),tampon, tamponbis
!         complex(kind=wp)          :: RZhi(Nmh,Nmh),RYhi(Nmh,Nmh)
!
!         Call ClassModeTE(Nmax,p,a,b,mh,kch)
!
!         Do i=1,Nmh
! !         RZh(i) = csqrt(Z0/csqrt((1.,0.)*(1-(kch(i)/k0)**2)))
!             tampon = (0.,1.)/((cl**2*Eps0)*sqrt((1.,0.)*(kch(i)**2-k0**2)))
!             tamponbis = k0*cl*tampon
!             RZh(i) = sqrt(tamponbis)
! !          RYh(i) = 1/RZh(i)
!         end do
!
!         sqrt_Zc_h = diag(RZh)
!
!     end function

    !
    !+ Generate an identity matrix of size dim x dim
    !
    function eye(dim)
        ! input var.
        Integer, intent(in) :: dim
        ! output var.
        Real(kind=wp)       :: eye(dim,dim)
        ! working var.
        Integer             :: i,j

        ! on s'assure de l'initialisation
        ! (meme si elle est parfois intrinseque selon le compilateur...)
        eye(:,:) = 0.0
        ! 1 sur la diagonale
        forall (i=1:dim, j=1:dim, i == j) eye(i,j) = 1.0
    end function eye

    !
    !+ Generate a diagonal matrix from a vector v
    !
    ! The matrix diag as the size (N,N), where N is the length of the vector v
    ! and diag(i,i)=v(i)
    !
    function diag(v)
        ! input var.
        complex(kind=wp), intent(in) :: v(:)
        ! output var.
        complex(kind=wp)             :: diag(size(v),size(v))

        diag = eye(size(v))*spread(v, 1, size(v))
    end function diag

    !
    !+ Real part of f011
    !
    function rf011(t)
        implicit none
        real(kind=wp) :: t(:)
        real(kind=wp) :: rf011(size(t))

        rf011=Real(f011(t))
    end function rf011

    !
    !+ Imaginary part of if011
    !
    function if011(t)
        real(kind=wp) :: t(:)
        real(kind=wp) :: if011(size(t))

        if011=aimag(f011(t))
    end function if011

    !
    !+ Real part of f012
    !
    function rf012(t)
        real(kind=wp) :: t(:)
        real(kind=wp) :: rf012(size(t))

        rf012=Real(f012(t))
    end function rf012

    !
    !+ Imaginary part of f012
    !
    function if012(t)
        Real(kind=wp) :: t(:)
        Real(kind=wp) :: if012(size(t))

        if012=aimag(f012(t))
    end function if012

      function rf0131(t)
        Real(kind=wp) :: t(:)
        Real(kind=wp) :: rf0131(size(t))

        rf0131=Real(f0131(t))
      end function rf0131

      function if0131(t)
        Real(kind=wp) :: t(:)
        Real(kind=wp) :: if0131(size(t))

        if0131=aimag(f0131(t))
      end function if0131

      function rf0132(t)
        Real(kind=wp) :: t(:)
        Real(kind=wp) :: rf0132(size(t))

        rf0132=Real(f0132(t))
      end function rf0132

      function if0132(t)
        Real(kind=wp) :: t(:)
        Real(kind=wp) :: if0132(size(t))

        if0132=aimag(f0132(t))
      end function if0132

      function rf0133(t)
        Real(kind=wp) :: t(:)
        Real(kind=wp) :: rf0133(size(t))

        rf0133=Real(f0133(t))
      end function rf0133

      function if0133(t)
        Real(kind=wp) :: t(:)
        Real(kind=wp) :: if0133(size(t))

        if0133=aimag(f0133(t))
      end function if0133

      function rf0134(t)
        Real(kind=wp) :: t(:)
        Real(kind=wp) :: rf0134(size(t))

        rf0134=Real(f0134(t))
      end function rf0134

      function if0134(t)
        Real(kind=wp) :: t(:)
        Real(kind=wp) :: if0134(size(t))

        if0134=aimag(f0134(t))
      end function if0134

      !
      !+ f011
      !
      function f011(t)
        use aloha_config, only : b,z,m,n,i,j,bcte,k0,X0,D0

        intrinsic epsilon, size
        ! input var.
        Real(kind=wp), intent(in) :: t(:)
        ! output var.
        Complex(kind=wp)          :: f011(size(t))
        ! working var.
        integer          :: p
        Real(kind=wp)    :: v(size(t))
        Real(kind=wp)    :: pc = epsilon(8.0)
        Complex(kind=wp) :: y(size(t)), ye(size(t))
        Complex(kind=wp) :: Aie(size(t)), Aied(size(t)),Ai(size(t)), Aid(size(t)), Airy(size(t))
        Complex(kind=wp) :: mode(size(t)), coupl(size(t)), f11(size(t))
        ! airy function error flag
        Integer          :: ierc

        v=(1.-t)/t

        y = (-v*(v+2.*(0.,1.)))**(1./3.)*(D0/X0)**(2./3.)*(X0-1.)*exp((0.,-1.)*pi/3.)
    !      y=(0.,0.)
        ye= y*exp((0.,1.)*2.*pi/3.)

!         write(*,*) 't=',t, ', v=', v
!         write(*,*) 'y=',y
!         write(*,*) 'ye=',ye

        do p=1,size(t)
            call airy_ai(ye(p), Aie(p), Aied(p), ierc)
            call airy_ai(y(p), Ai(p), Aid(p), ierc)

!             Aied(p)=nag_airy_ai(ye(p), deriv=.true. , scale=.false.)
!              Aie(p)=nag_airy_ai(ye(p), deriv=.false., scale=.false.)
!              Aid(p)=nag_airy_ai(y(p) , deriv=.true. , scale=.false.)
!               Ai(p)=nag_airy_ai(y(p) , deriv=.false., scale=.false.)
        end do
!         write(*,*) 'pc=', pc
!         write(*,*) 'Ai=', Ai
!         write(*,*) 'Aie=', Aie
!         write(*,*) ''
!         pause

        Airy=(Aid/Ai)-exp((0.,-1.)*4.*pi/3.)*(Aied/Aie)

        mode=(-1.+(0.,1.)*v)**2/(-v*(v+2.*(0.,1.)))**(2./3.) &
        /(((-1.+(0.,1.)*v)**2-(n*pi/(k0*b(i)))**2)*((-1.+(0.,1.)*v)**2-(m*pi/(k0*b(j)))**2))*exp((0.,1.)*pi/6.)*(0.,1.)

        coupl=(2.,0.)

        f011=(-1.,0.)*Airy*mode*coupl/(t*t)
        ! MAJ JH 30/04/2009
        ! Le code suivant est une reprise du code fortran 77 :
        ! Dans le code originel, pc=1e-300.
        ! lorsque le resultat des fontions d'Airy est inferieur a cette valeur
        ! alors l'intégrande est nulle.
        ! Cela correspond a la limite lorsque y->+oo, et on a Q->0 soit f011->0.
        ! Dans la version fortran90, j'avais limite pc au plus petit reel non negligeable.
        ! Toutefois, du a l'existence du OR, cette valeur pouvait etre trop petite, et ainsi
        ! fausser le resultat final en le mettant a 0 au lieu d'une petite valeur.
        ! Le code suivant est donc laisse en commentaire, tout comme dansles fonctions suivantes.
!         do p=1,size(t)
!             if (abs(Ai(p)) < pc.OR.abs(Aie(p)) < pc) then
!                 f011(p)=(0.,0.)
!             end if
!         end do
    end function

    !
    !+ f012
    !
    function f012(t)
        use aloha_config, only : b,z,m,n,i,j,bcte,k0,X0,D0
        intrinsic epsilon, size

        ! input var.
        real(kind=wp), intent(in) :: t(:)
        ! output var.
        complex(kind=wp)          :: f012(size(t))

        ! working var.
        integer             :: p
        real(kind=wp)       :: v(size(t)), pc = epsilon(8.0)!k0,X0,D0,z(60),b(60),pi,pc!,mn
        complex(kind=wp)    :: y(size(t)), ye(size(t))
        complex(kind=wp)    :: Aie(size(t)), Aied(size(t)), Ai(size(t)), Aid(size(t)), Airy(size(t))
        complex(kind=wp)    :: mode(size(t)), coupl(size(t)), f12(size(t))
        ! airy function error flag
        Integer             :: ierc

        v=(1.-t)/t

        y=(-v*(v+2.*(0.,1.)))**(1./3.)*(D0/X0)**(2./3.)*(X0-1.)*exp((0.,-1.)*pi/3.)
        !      y=(0.,0.)
        ye=y*exp((0.,1.)*2.*pi/3.)

        do p=1,size(t)
            call airy_ai(ye(p), Aie(p), Aied(p), ierc )
            call airy_ai(y(p), Ai(p), Aid(p), ierc )
!             Aied(p)=nag_airy_ai(ye(p), deriv=.true. , scale=.false.)
!              Aie(p)=nag_airy_ai(ye(p), deriv=.false., scale=.false.)
!              Aid(p)=nag_airy_ai(y(p) , deriv=.true. , scale=.false.)
!               Ai(p)=nag_airy_ai(y(p) , deriv=.false., scale=.false.)
        end do

        Airy=(Aid/Ai)-exp((0.,-1.)*4.*pi/3.)*(Aied/Aie)

        mode=(-1.+(0.,1.)*v)**2/(-v*(v+2.*(0.,1.)))**(2./3.) &
        /(((-1.+(0.,1.)*v)**2-(n*pi/(k0*b(i)))**2)*((-1.+(0.,1.)*v)**2-(m*pi/(k0*b(j)))**2))*exp((0.,1.)*pi/6.)*(0.,1.)

        !      coupl=(2.,0.)*(-(-1.)**m*exp((0.,1.)*k0*(-1+(0.,1.)*v)*b(i)))
        coupl=(2.,0.)*(-(-1.)**n*exp((0.,1.)*k0*(-1+(0.,1.)*v)*b(i)))

        f012=(-1.,0.)*Airy*mode*coupl/(t*t)

!          do p=1,size(t)
!             if (abs(Ai(p)) < pc.OR.abs(Aie(p)) < pc) Then
!                 f012(p)=(0.,0.)
!             endif
!         end do
    end function

    !
    !+ f0131
    !
    function f0131(t)
        use aloha_config, only : b,z,m,n,i,j,k0,X0,D0
        intrinsic epsilon, size

        ! input var.
        real(kind=wp), intent(in) :: t(:)
        ! output var.
        complex(kind=wp)          :: f0131(size(t))
        ! working var.
        integer          :: p
        real(kind=wp)    :: v(size(t)), pc = epsilon(8.0)
        complex(kind=wp) :: y(size(t)), ye(size(t))
        complex(kind=wp) :: Aie(size(t)), Aied(size(t)), Ai(size(t)), Aid(size(t)), Airy(size(t))
        complex(kind=wp) :: mode(size(t)), coupl(size(t))
        ! airy function error flag
        Integer          :: ierc

        v=(1.-t)/t

        y=(-v*(v+2.*(0.,1.)))**(1./3.)*(D0/X0)**(2./3.)*(X0-1.)*exp((0.,-1.)*pi/3.)
    !      y=(0.,0.)
        ye=y*exp((0.,1.)*2.*pi/3.)
        do p=1,size(t)
            call airy_ai(ye(p), Aie(p), Aied(p), ierc )
            call airy_ai(y(p), Ai(p), Aid(p), ierc )
!              Aied(p)=nag_airy_ai(ye(p), deriv=.true. , scale=.false.)
!               Aie(p)=nag_airy_ai(ye(p), deriv=.false., scale=.false.)
!               Aid(p)=nag_airy_ai(y(p) , deriv=.true. , scale=.false.)
!                Ai(p)=nag_airy_ai(y(p) , deriv=.false., scale=.false.)
        end do

        Airy=(Aid/Ai)-exp((0.,-1.)*4.*pi/3.)*(Aied/Aie)

        mode=(-1.+(0.,1.)*v)**2/(-v*(v+2.*(0.,1.)))**(2./3.) &
        /(((-1.+(0.,1.)*v)**2-(n*pi/(k0*b(i)))**2)*((-1.+(0.,1.)*v)**2-(m*pi/(k0*b(j)))**2))*exp((0.,1.)*pi/6.)*(0.,1.)

        coupl=exp((0.,1.)*k0*(-1+(0.,1.)*v)*abs(z(j)-z(i)))

        f0131=(-1.,0.)*Airy*mode*coupl/(t*t)

!         do p=1,size(t)
!             if (abs(Ai(p)) < pc.OR.abs(Aie(p)) < pc) Then
!                 f0131(p)=(0.,0.)
!             end if
!         end do
    end function

    !
    !+ f0132
    !
    function f0132(t)
        use aloha_config, only : b,z,m,n,i,j,k0,X0,D0
        intrinsic epsilon, size

        ! input var.
        real(kind=wp), intent(in) :: t(:)
        ! output var.
        complex(kind=wp)          :: f0132(size(t))
        ! working var.
        integer          :: p
        real(kind=wp)    :: v(size(t)), pc = epsilon(8.0)
        complex(kind=wp) :: y(size(t)), ye(size(t))
        complex(kind=wp) :: Aie(size(t)), Aied(size(t)), Ai(size(t)), Aid(size(t)), Airy(size(t))
        complex(kind=wp) :: mode(size(t)), coupl(size(t))
        ! airy function error flag
        Integer          :: ierc

        v=(1.-t)/t

        y=(-v*(v+2.*(0.,1.)))**(1./3.)*(D0/X0)**(2./3.)*(X0-1.)*exp((0.,-1.)*pi/3.)
        !      y=(0.,0.)
        ye=y*exp((0.,1.)*2.*pi/3.)

        do p=1,size(t)
            call airy_ai(ye(p), Aie(p), Aied(p), ierc )
            call airy_ai(y(p), Ai(p), Aid(p), ierc )
!                 Aied(p)=nag_airy_ai(ye(p), deriv=.true. , scale=.false.)
!                 Aie(p)=nag_airy_ai(ye(p), deriv=.false., scale=.false.)
!                 Aid(p)=nag_airy_ai(y(p) , deriv=.true. , scale=.false.)
!                 Ai(p)=nag_airy_ai(y(p) , deriv=.false., scale=.false.)
        end do

        Airy=(Aid/Ai)-exp((0.,-1.)*4.*pi/3.)*(Aied/Aie)

        mode=(-1.+(0.,1.)*v)**2/(-v*(v+2.*(0.,1.)))**(2./3.) &
        /(((-1.+(0.,1.)*v)**2-(n*pi/(k0*b(i)))**2)*((-1.+(0.,1.)*v)**2-(m*pi/(k0*b(j)))**2))*exp((0.,1.)*pi/6.)*(0.,1.)

        coupl=exp((0.,1.)*k0*(-1+(0.,1.)*v)*abs(z(j)-z(i)+b(j)-b(i)))

        f0132=(-1.,0.)*Airy*mode*coupl/(t*t)

!         do p=1,size(t)
!             If (abs(Ai(p)) < pc.OR.abs(Aie(p)) < pc) Then
!                 f0132(p)=(0.,0.)
!             end if
!         end do
    End function

    !
    !+ f0133
    !
    function f0133(t)
        use aloha_config, only : b,z,m,n,i,j,k0,X0,D0
        intrinsic epsilon, size

        ! input var.
        real(kind=wp), intent(in) :: t(:)
        ! output var.
        complex(kind=wp)          :: f0133(size(t))
        ! working var.
        integer          :: p
        real(kind=wp)    :: v(size(t)), pc = epsilon(8.0)
        complex(kind=wp) :: y(size(t)), ye(size(t))
        complex(kind=wp) :: Aie(size(t)), Aied(size(t)), Ai(size(t)), Aid(size(t)), Airy(size(t))
        complex(kind=wp) :: mode(size(t)), coupl(size(t))
        ! airy function error flag
        Integer          :: ierc

        v=(1.-t)/t

        y=(-v*(v+2.*(0.,1.)))**(1./3.)*(D0/X0)**(2./3.)*(X0-1.)*exp((0.,-1.)*pi/3.)
    !      y=(0.,0.)
        ye=y*exp((0.,1.)*2.*pi/3.)

        do p=1,size(t)
            call airy_ai(ye(p), Aie(p), Aied(p), ierc )
            call airy_ai(y(p), Ai(p), Aid(p), ierc )
!               Aied(p)=nag_airy_ai(ye(p), deriv=.true. , scale=.false.)
!                Aie(p)=nag_airy_ai(ye(p), deriv=.false., scale=.false.)
!                Aid(p)=nag_airy_ai(y(p) , deriv=.true. , scale=.false.)
!                 Ai(p)=nag_airy_ai(y(p) , deriv=.false., scale=.false.)
        end do

        Airy=(Aid/Ai)-exp((0.,-1.)*4.*pi/3.)*(Aied/Aie)

        mode=(-1.+(0.,1.)*v)**2/(-v*(v+2.*(0.,1.)))**(2./3.) &
        /(((-1.+(0.,1.)*v)**2-(n*pi/(k0*b(i)))**2)*((-1.+(0.,1.)*v)**2-(m*pi/(k0*b(j)))**2))*exp((0.,1.)*pi/6.)*(0.,1.)

        coupl=exp((0.,1.)*k0*(-1+(0.,1.)*v)*abs(z(j)-z(i)+b(j)))

        f0133=(-1.,0.)*Airy*mode*coupl/(t*t)

!         do p=1,size(t)
!             If (abs(Ai(p)) < pc.OR.abs(Aie(p)) < pc) Then
!                 f0133(p)=(0.,0.)
!             endif
!         end do

    End function

    !
    !+ f0134
    !
    function f0134(t)
        use aloha_config, only : b,z,m,n,i,j,k0,X0,D0
        intrinsic epsilon, size

        ! input var.
        real(kind=wp), intent(in) :: t(:)
        ! output var.
        complex(kind=wp)          :: f0134(size(t))
        ! working var.
        integer          :: p
        real(kind=wp)    :: v(size(t)), pc = epsilon(8.0)
        complex(kind=wp) :: y(size(t)), ye(size(t))
        complex(kind=wp) :: Aie(size(t)), Aied(size(t)), Ai(size(t)), Aid(size(t)), Airy(size(t))
        complex(kind=wp) :: mode(size(t)), coupl(size(t))
        ! airy function error flag
        Integer          :: ierc
!         write(*,*) ' in f0134...'
        v=(1.-t)/t

        y=(-v*(v+2.*(0.,1.)))**(1./3.)*(D0/X0)**(2./3.)*(X0-1.)*exp((0.,-1.)*pi/3.)
    !      y=(0.,0.)
        ye=y*exp((0.,1.)*2.*pi/3.)

        do p=1,size(t)
            call airy_ai(ye(p), Aie(p), Aied(p), ierc )
            call airy_ai(y(p), Ai(p), Aid(p), ierc )
!               Aied(p)=nag_airy_ai(ye(p), deriv=.true. , scale=.false.)
!                Aie(p)=nag_airy_ai(ye(p), deriv=.false., scale=.false.)
!                Aid(p)=nag_airy_ai(y(p) , deriv=.true. , scale=.false.)
!                 Ai(p)=nag_airy_ai(y(p) , deriv=.false., scale=.false.)
        end do

        Airy=(Aid/Ai) - exp((0.,-1.)*4.*pi/3.)*(Aied/Aie)

        mode=(-1.+(0.,1.)*v)**2/(-v*(v+2.*(0.,1.)))**(2./3.) &
        /(((-1.+(0.,1.)*v)**2-(n*pi/(k0*b(i)))**2)*((-1.+(0.,1.)*v)**2-(m*pi/(k0*b(j)))**2))*exp((0.,1.)*pi/6.)*(0.,1.)

        coupl=exp((0.,1.)*k0*(-1+(0.,1.)*v)*abs(z(j)-z(i)-b(i)))

        f0134=(-1.,0.)*Airy*mode*coupl/(t*t)

!         do p=1,size(t)
!             If (abs(Ai(p)) < pc .OR. abs(Aie(p)) < pc) Then
!                 f0134(p)=(0.,0.)
!             end if
!         end do

    End function

    ! ***
    ! Suroutine de CALcul de RESIDUs
    !
    ! INPUT
    !
    ! OUTPUT
    !
    Subroutine Calresidu(residu)

    use aloha_config, only : b, z, m, n, i, j, k0, X0, D0

    implicit none

!     Common/dims/b,z
!     Common/modmn/m,n
!     Common/guid/i,j
!     Common/onde/k0
!     Common/plasma/X0,D0

    Complex(kind=wp), intent(out) :: residu

    !Integer :: m,n!,ifail,nz,i,j
    !Real(kind=wp) :: PI,z(60),b(60),k0,X0,D0!,pc
    Complex(kind=wp) :: y, Ai, Aid
    ! airy function error flag
    Integer          :: ierc

    If ((m == n).AND.(i == j)) Then
!        write(*,*) 'k0=',k0,'n=',n,'b(i)=',b(i),'D0=',D0,'X0=',X0,'pi=',pi
       ! TODO ? JH 10/2008: Il y'a un bug dans gfortran 4.2. Lorsqu'il evalue
       ! la soustraction d'un complexe, le signe de la partie reelle influe anormalement
       ! sur le resultat. Ainsi, on est oblige de tester si la partie reelle est nulle.
       ! Si c'est le cas, on doit alors "forcer le signe du 0", car selon le mode de
       ! compilation (optimisation ou non), le compilateur prendra la partie reelle de 0
       ! negative ou positive...
       ! Pour obtenir le bon resultat avec gfortran, il ne faut donc pas compiler avec le
       ! flag 'optimisation' -O[1-3]
       y=((1.,0.)*(n*pi/(k0*b(i)))**2-(1.,0.))**(1./3.)*(D0/X0)**(2./3.)*(X0-1.)*exp((0.,-1.)*pi/3.)

!        write(*,*) '(n*pi/(k0*b(i)))**2=',(n*pi/(k0*b(i)))**2
!        write(*,*) '(-(1.,0.))**(1./3.)=',(-(1.,0.))**(1./3.)
!        write(*,*) '((0.,0.)-(1.,0.))**(1./3.)=',((0.,0.)-(1.,0.))**(1./3.)
!        write(*,*) '(+(0.,0.)-(1.,0.))**(1./3.)=',(+(0.,0.)-(1.,0.))**(1./3.)
!        write(*,*) '(-(0.,0.)-(1.,0.))**(1./3.)=',(-(0.,0.)-(1.,0.))**(1./3.)
!        write(*,*) ''
!        write(*,*) '((n*pi/(k0*b(i)))**2-(1.,0.))**(1./3.)=',((n*pi/(k0*b(i)))**2-(1.,0.))**(1./3.)
!        write(*,*) '((1.,0.)*(n*pi/(k0*b(i)))**2-(1.,0.))**(1./3.)=',((1.,0.)*(n*pi/(k0*b(i)))**2-(1.,0.))**(1./3.)

!        write(*,*) 'y=', y
       call airy_ai(y, Ai, Aid, ierc)
!        write(*,*) 'Ai=', Ai, 'Aid=', Aid

! !      NAG
!        Aid = nag_airy_ai(y, deriv=.true., scale=.false. ) ! JH 17/04/2008 F90
!        Ai  = nag_airy_ai(y, deriv=.false., scale=.false. ) ! JH 17/04/2008 F90

        If (n == 0) Then
            residu=-2.*PI*k0*b(i)*Aid/Ai/((1.,0.)*(n*PI/(k0*b(i)))**2-(1.,0.))**(2./3.)*exp((0.,1.)*PI/6.)
        Else
            residu=-PI*k0*b(i)*Aid/Ai/((1.,0.)*(n*PI/(k0*b(i)))**2-(1.,0.))**(2./3.)*exp((0.,1.)*PI/6.)
        EndIf

    Else
        residu=(0.,0.)
    EndIf

    End subroutine Calresidu

    ! ***
    ! Suroutine de CALcul de RESIDUs en dimension y (integrale I_y)
    !
    ! Les poles apparaissent uniquement lorsque les indices mi et mj
    ! sont egaux. Dans un tel cas, la contribution des residus a
    ! l'integrale I_y est donnée dans [Berio, p146-148, eq. A.III.5]
    !
    ! Input arguments :
    !  - a  : largeur du guide (dir. poloidale)
    !  - mi : premier indice (dir. poloidal) m du mode (m,n) du guide p
    !  - mj : premier indice (dir. poloidal) m du mode (m,n) du guide q
    !
    ! Output argument :
    ! - residuy
    !
    Subroutine Calresiduy(a, mi, mj, residuy)
        use aloha_config, only : k0

        Integer,       intent(in) :: mi, mj
        Real(kind=wp), intent(in) :: a
        Real(kind=wp), intent(out):: residuy

        If (mi == mj) Then
            If (mi /= 0) Then
                residuy=pi*k0*a/((mi*pi/(k0*a))**2.)
            Else
                write (*,*) 'pb mi=mj=0'
                stop
                ! residuy=PI*(k0*a)**3./3.
            EndIf
        Else ! mi /= mj
            residuy=(0.,0.)
        EndIf
    End subroutine

      !*********
      ! Couplage au plasma (V6)
      !
      !call airy_ai(ye(p), Aie(p), Aied(p), ierc)
      !
      !TODO : les fonctions d'airy bi ne sont calculees que pour des valeurs reelles.
      !       il faudrait trouver une routine permettant le calcul complexe.
      !
      !*********
      function f_nz(nz)

        use aloha_config, only : b, z, m, n, i, j, k0, X0, D0, d_couche, X1, D1, pertes, d_vide

        implicit none

        Real(kind=wp)   , intent(in)  :: nz(:)
        Complex(kind=wp)              :: f_nz(size(nz))

        Real(kind=wp), parameter :: PC_limit=epsilon(8.0)
        Complex(kind=wp) :: alpha
        Complex(kind=wp), Dimension(size(nz)) :: neta
        Complex(kind=wp), Dimension(size(nz)) :: Ai, Aid, Ai_0, Aid_0, Ai_d, Aid_d
        Real(kind=wp)   , Dimension(size(nz)) :: Bi_0, Bid_0, Bi_d, Bid_d
        Complex(kind=wp), Dimension(size(nz)) :: ya, y_L, yb, num, denom, ys, ys_sur_factor, gamma, tanh_d_vide, y0
        Integer  :: ierc, p
        Real(kind=wp) :: z_r, z_i
        Complex(kind=wp) :: u

        alpha=(1.,0.)-(0.,1.)*pertes

        neta=((1.,0.)*nz**2-alpha)**(1./3.)*(D1/X1)**(2./3.)*(X1-1.)*exp(-(0.,1.)*pi/3.)

        do p=1,size(nz)
            call airy_ai(neta(p), Ai(p), Aid(p), ierc)

            If (abs(Ai(p)) < PC_limit) Then
                f_nz = (0.,0.)
                return
            Else
                y_L(p) = -alpha*(Aid(p)/Ai(p))*(X1/D1)**(1./3.)/((1.,0.)*nz(p)**2-alpha)**(2./3.)*exp((0.,1.)*pi/6.)
            EndIf

            neta(p)=((1.,0.)*nz(p)**2-alpha)**(1./3.)*(D0/X0)**(2./3.)*(X0-1.)*exp(-(0.,1.)*pi/3.)

            call airy_ai(neta(p), Ai_0(p), Aid_0(p), ierc)

            If (abs(Ai_0(p)) < PC_limit) Then
                f_nz = (0.,0.)
                return
            Else
                ya(p) = -alpha*(Aid_0(p)/Ai_0(p))*(X0/D0)**(1./3.)/((1.,0.)*nz(p)**2-alpha)**(2./3.)*exp((0.,1.)*pi/6.)
            EndIf

            call airy_bi(real(neta(p)), Bi_0(p), Bid_0(p), ierc, .FALSE.)

            If (abs(Bi_0(p)) < PC_limit) Then
                f_nz = (0.,0.)
                return
            Else
                yb(p) = -alpha*(Bid_0(p)/Bi_0(p))*(X0/D0)**(1./3.)/((1.,0.)*nz(p)**2-alpha)**(2./3.)*exp((0.,1.)*pi/6.)
            EndIf

            neta(p) = ((1.,0.)*nz(p)**2-alpha)**(1./3.)*(X0/D0)**(1./3.)*(k0*d_couche+(D0/X0)*(X0-1.))*exp(-(0.,1.)*pi/3.)

            call airy_ai(neta(p), Ai_d(p), Aid_d(p), ierc)
            call airy_bi(real(neta(p)), Bi_d(p), Bid_d(p), ierc, .FALSE.)

            If ((abs(Bid_0(p)) < PC_limit).OR.(abs(Aid_0(p)) < PC_limit)) Then
                f_nz = (0.,0.)
                return
            Else
                num(p) = y_L(p)*(Ai_d(p)/Ai_0(p)*yb(p)-Bi_d(p)/Bi_0(p)*ya(p))+ya(p)*yb(p)*(Bid_d(p)/Bid_0(p)-Aid_d(p)/Aid_0(p))
                denom(p) = y_L(p)*(Ai_d(p)/Ai_0(p)-Bi_d(p)/Bi_0(p))-Aid_d(p)/Aid_0(p)*ya(p)+Bid_d(p)/Bid_0(p)*yb(p)
            Endif

            ys(p)=num(p)/denom(p)

!             ! Special cases to avoid : nz=+/-1
!             If (abs(nz(p)) == 1.0)then
!                 write(*,*) 'nz=1, ys(nz)=',ys(p)
!                 ys(p) = 0.0
!             EndIf

            ! Admittance propagation inside the vacuum layer of length d_vide
            gamma(p) = k0*(nz(p)**2-alpha)**(1./2.)

            ! Hyperbolic tangent calculation : tanh(gamma*v_dide)
            ! This calculation may generate NaN, which ultimatly lead to crappy NaN integration results...
            !
            ! Expression 1 (definition) --> produces NaN
            !tanh_d_vide(p) = (exp(2*gamma(p)*d_vide)-1)/(exp(2*gamma(p)*d_vide)+1)
            ! Expression 2 (built in function)  --> Complex tanh only in Fortran 2008 !
            !tanh_d_vide(p) = tanh(gamma(p)*d_vide)
            ! Expression 3 (alternate x+iy form) --> produces NaN
            !z_r = real(gamma(p)*d_vide)
            !z_i = aimag(gamma(p)*d_vide)
            !tanh_d_vide(p) = (sinh(2*z_r) + (0.,1.)*sin(2*z_i))/(cosh(2*z_r) + cos(2*z_i))
            ! Expression 4 : limit --> works !
            tanh_d_vide(p) = gamma(p)*d_vide
            ! Expression 5 : Taylor expansion of the tanh function (source: wikipedia) --> works also !
            !u = gamma(p)*d_vide
            !tanh_d_vide(p) = u - (u**3.)/3. + 2.*(u**5.)/15. - 17.*(u**7.)/315.

            y0(p) = (0.,1.)*k0/gamma(p)

            ys(p) = y0(p)*(ys(p)+y0(p)*tanh_d_vide(p))/(ys(p)*tanh_d_vide(p)+y0(p))

            ys_sur_factor(p)=ys(p)/((X0/D0)**(1./3.))

            If (isnan(real(ys(p)))) then
                write(*,*) 'NaN detected ! '
                write(*,*) 'nz=',nz(p)
                write(*,*) 'gamma=', gamma(p)
                write(*,*) 'tanh_d_vide', tanh_d_vide(p)
                write(*,*) 'y0(p)', y0(p)
                write(*,*) 'ys(p)', ys(p)
            EndIf

        endDo

        f_nz = nz**2.*ys_sur_factor*(1.-(-1.)**n*exp((0.,1.)*k0*nz*b(i)))* &
         1/(nz**2-(n*pi/(k0*b(i)))**2)* &
         (1.-(-1.)**m*exp((0.,-1.)*k0*nz*b(j)))* &
         1/(nz**2-(m*pi/(k0*b(j)))**2)* &
         exp((0.,1.)*k0*nz*(z(i)-z(j)))

      End function f_nz

      !
      ! rf_nz(nz)
      !
      ! Real part of f_nz
      !
      function rf_nz(nz)
        implicit none
        Real(kind=wp) :: nz(:)
        Real(kind=wp) :: rf_nz(size(nz))

        rf_nz = real(f_nz(nz))

      End function rf_nz

      !
      ! if_nz(nz)
      !
      ! imaginary part of f_nz
      !
      function if_nz(nz)
        implicit none
        Real(kind=wp) :: nz(:)
        Real(kind=wp) :: if_nz(size(nz))

        if_nz = aimag(f_nz(nz))

      End function if_nz

END MODULE aloha_function


MODULE Nonc_chisq
IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

! COMMON /qfcom/ aintl,ersm,pi,aln28,sigsq,almax,almin,amean,c,  &
!    icount,ir,ndtsrt,fail,lim
REAL (dp), SAVE  :: aintl, ersm
REAL, SAVE       :: pi, aln28, sigsq, almax, almin, amean, c
INTEGER, SAVE    :: icount, ir, lim
LOGICAL, SAVE    :: ndtsrt, fail

CONTAINS

FUNCTION iround(x) RESULT(ival)
IMPLICIT NONE

REAL, INTENT(IN)  :: x
INTEGER           :: ival

REAL, PARAMETER  :: half = 0.5

ival = INT(x + SIGN(half,x))
RETURN
END FUNCTION iround

FUNCTION qf(alb, anc, n, irr, sigma, cc, lim1, acc, ith, trace, ifault)  &
   RESULT(fn_val)

! Code converted using TO_F90 by Alan Miller
! Date: 2004-01-06  Time: 08:37:41

!     ALGORITHM AS 155  APPL. STATIST. (1980) VOL.29, NO.3

!     Distribution of a linear combination of non-central chi-squared
!     random variables.

IMPLICIT NONE
INTEGER, INTENT(IN)   :: irr
REAL, INTENT(IN)      :: alb(irr)
REAL, INTENT(IN)      :: anc(irr)
INTEGER, INTENT(IN)   :: n(irr)
REAL, INTENT(IN)      :: sigma
REAL, INTENT(IN)      :: cc
INTEGER, INTENT(IN)   :: lim1
REAL, INTENT(IN)      :: acc
INTEGER, INTENT(OUT)  :: ith(irr)
REAL, INTENT(OUT)     :: trace(7)
INTEGER, INTENT(OUT)  :: ifault
REAL                  :: fn_val

INTEGER  :: j, nj, nt, ntm
REAL     :: acc1, almx, xlim, xnt, xntm
REAL     :: utx, tausq, sd, aintv, aintv1, x, up, un, d1, d2, alj, ancj
REAL (dp) :: aintl, ersm
REAL     :: pi, aln28, sigsq, almax, almin, amean, c
INTEGER  :: icount, ir, lim
LOGICAL  :: ndtsrt, fail
REAL, PARAMETER  :: zero = 0.0, half = 0.5, one = 1.0, two = 2.0, four = 4.0, &
    sixtn = 16.0, fourp5 = 4.5, pt07 = 0.07, pt2 = 0.2, quart = 0.25,  &
    ten = 10.0, pt33 = 0.33, pt67 = 0.67, pt75 = 0.75, onept5 = 1.5,  &
    three = 3.0, onept1 = 1.1

!     Setting constants in COMMON.   ALN28 = ln(2) / 8.

pi = 3.14159265358979
aln28 = 0.0866

c = cc
ir = irr
lim = lim1
trace(1:7) = zero
ifault = 0
icount = 0
aintl = zero
ersm = zero
fn_val = -one
acc1 = acc
ndtsrt = .true.
fail = .false.

!     Find mean, sd, max & min of ALB.
!     Check that parameter values are valid.

xlim = lim
sigsq = sigma**2
sd = sigsq
almax = zero
almin = zero
amean = zero
j = 1

20 IF (.NOT.(j <= ir)) GO TO 60
nj = n(j)
alj = alb(j)
ancj = anc(j)
IF (.NOT.(nj < 0 .OR. ancj < zero)) GO TO 30
ifault = 3
GO TO 260

30 sd = sd + alj**2*(2*nj + four*ancj)
amean = amean + alj*(nj + ancj)
IF (.NOT.(almax < alj)) GO TO 40
almax = alj
GO TO 50

40 IF (.NOT.(almin > alj)) GO TO 50
almin = alj
50 j = j + 1
GO TO 20

60 IF (.NOT.(sd == zero)) GO TO 80
IF (.NOT.(c > zero)) GO TO 70
fn_val = one
GO TO 260

70 fn_val = zero
GO TO 260
80 IF (.NOT.(almin == zero .AND. almax == zero .AND. sigma == zero)) GO TO 90
ifault = 3
GO TO 260

90 sd = SQRT(sd)
IF (.NOT.(almax < -almin)) GO TO 100
almx = -almin
GO TO 110
100 almx = almax

!     Starting values for FINDU * CTFF.

110 utx = sixtn/sd
up = fourp5/sd
un = -up

!     Truncation point with no convergence factor.

CALL findu (n, alb, anc, utx, half*acc1)

!     Does convergence factor help ?

IF (.NOT.(c /= zero .AND. almx > pt07*sd)) GO TO 130
tausq = quart*acc1/cfe(n, alb, anc, ith, c)
IF (.NOT.(fail)) GO TO 120
fail = .false.
GO TO 130

120 IF (.NOT.(truncn(n, alb, anc, utx, tausq) < pt2*acc1)) GO TO 130
sigsq = sigsq + tausq
CALL findu (n, alb, anc, utx, quart*acc1)
trace(6) = SQRT(tausq)
130 trace(5) = utx
acc1 = half*acc1

!     Find 'range' of distribution, quit if outside of this.

140 d1 = ctff(n, alb, anc, acc1, up) - c
IF (.NOT.(d1 < zero)) GO TO 150
fn_val = one
GO TO 260
150 d2 = c - ctff(n, alb, anc, acc1, un)
IF (.NOT.(d2 < zero)) GO TO 160
fn_val = zero
GO TO 260

!     Find integration interval.

160 IF (.NOT.(d1 > d2)) GO TO 170
aintv = d1
GO TO 180
170 aintv = d2
180 aintv = two*pi/aintv

!     Calculate number of terms required for main & auxiliary
!     integrations.

xnt = utx/aintv
xntm = three/SQRT(acc1)
IF (.NOT.(xnt > xntm*onept5)) GO TO 220
IF (.NOT.(xntm > xlim)) GO TO 190
ifault = 1
GO TO 260

!     Parameters for auxiliary integration.

190 ntm = iround(xntm)
aintv1 = utx/xntm
x = two*pi/aintv1
IF (.NOT.(x <= ABS(c))) GO TO 200
GO TO 220

!     Calculate convergence factor.

200 tausq = cfe(n, alb, anc, ith, c - x) + cfe(n, alb, anc, ith, c + x)
tausq = pt33*acc1/(onept1*tausq)
IF (.NOT.(fail)) GO TO 210
GO TO 220
210 acc1 = pt67*acc1

!     Auxiliary integration.

CALL integr (n, alb, anc, ntm, aintv1, tausq, .false.)
xlim = xlim - xntm
sigsq = sigsq + tausq
trace(3) = trace(3) + 1
trace(2) = trace(2) + ntm + 1

!     Find truncation point with new convergence factor.

CALL findu (n, alb, anc, utx, quart*acc1)
acc1 = pt75*acc1
GO TO 140

!     Main integration.

220 trace(4) = aintv
IF (.NOT.(xnt > xlim)) GO TO 230
ifault = 1
GO TO 260

230 nt = iround(xnt)
CALL integr (n, alb, anc, nt, aintv, zero, .true.)
trace(3) = trace(3) + 1
trace(2) = trace(2) + nt + 1
fn_val = half - aintl
trace(1) = ersm
up = ersm

!     Test whether round-off error could be significant.
!     Allow for radix 8 or 16 machines.

x = up + acc/ten
j = 1
240 IF (.NOT.(j <= 8)) GO TO 260
IF (.NOT.(j*x == j*up)) GO TO 250
ifault = 2
250 j = j*2
GO TO 240

260 trace(7) = icount
RETURN
END FUNCTION qf

SUBROUTINE countr()

!     Count number of calls to ERRBD, TRUNCN & CFE.

IMPLICIT NONE
! COMMON /qfcom/ aintl,ersm,pi,aln28,sigsq,almax,almin,amean,c,  &
!    icount,ir,ndtsrt,fail,lim

icount = icount + 1
IF (.NOT.(icount > lim)) GO TO 20
WRITE (6, 10)
10 FORMAT (' qf: cannot locate integration parameters'/)
STOP
20 RETURN
END SUBROUTINE countr

FUNCTION alog1(x, first) RESULT(fn_val)

!     If FIRST then return ln(1 + x) else ln(1 + x) - x.

IMPLICIT NONE
REAL, INTENT(IN)     :: x
LOGICAL, INTENT(IN)  :: first
REAL                 :: fn_val

REAL    :: s, s1, term, y, ak
REAL, PARAMETER  :: pt1 = 0.1, one = 1.0, two = 2.0, three = 3.0

IF (.NOT.(ABS(x) > pt1)) GO TO 20
IF (.NOT.(first)) GO TO 10
fn_val = LOG(one + x)
GO TO 70

10 fn_val = LOG(one + x) - x
GO TO 70

20 y = x/(two + x)
term = two*y**3
ak = three
IF (.NOT.(first)) GO TO 30
s = two
GO TO 40

30 s = -x
40 s = s*y
y = y**2
s1 = s + term/ak

50 IF (.NOT.(s1 /= s)) GO TO 60
ak = ak + two
term = term*y
s = s1
s1 = s + term/ak
GO TO 50

60 fn_val = s
70 RETURN
END FUNCTION alog1

FUNCTION exp1(x) RESULT(fn_val)

IMPLICIT NONE
REAL, INTENT(IN)  :: x
REAL              :: fn_val

REAL, PARAMETER  :: zero = 0.0, neg50 = -50.0

IF (.NOT.(x < neg50)) GO TO 10
fn_val = zero
GO TO 20
10 fn_val = EXP(x)
20 RETURN
END FUNCTION exp1

SUBROUTINE order (alb, ith)

!     Find order of absolute values of ALB.

IMPLICIT NONE
REAL, INTENT(IN)         :: alb(*)
INTEGER, INTENT(IN OUT)  :: ith(*)

INTEGER  :: j, k, k1, ithk
REAL     :: alj
! COMMON /qfcom/ aintl,ersm,pi,aln28,sigsq,almax,almin,amean,c,  &
!    icount,ir,ndtsrt,fail,lim

j = 1
10 IF (.NOT.(j <= ir)) GO TO 60
alj = ABS(alb(j))
k = j - 1
20 IF (.NOT.(k > 0)) GO TO 40
ithk = ith(k)
k1 = k + 1
IF (.NOT.(alj > ABS(alb(ithk)))) GO TO 50
ith(k1) = ithk
k = k - 1
GO TO 20

40 k = 0
k1 = 1
50 ith(k1) = j
j = j + 1
GO TO 10

60 ndtsrt = .false.
RETURN
END SUBROUTINE order

FUNCTION errbd(n, alb, anc, uu, cx) RESULT(fn_val)

!     Find bound on tail probability using mgf.
!     Cut-off point returned to CX.

IMPLICIT NONE
INTEGER, INTENT(IN)  :: n(*)
REAL, INTENT(IN)     :: alb(*)
REAL, INTENT(IN)     :: anc(*)
REAL, INTENT(IN)     :: uu
REAL, INTENT(OUT)    :: cx
REAL                 :: fn_val

REAL     :: u
REAL     :: sum1, alj, ancj, x, y, const
INTEGER  :: j, nj
! COMMON /qfcom/ aintl, ersm, pi, aln28, sigsq, almax, almin, amean, c,  &
!    icount,ir,ndtsrt,fail,lim
REAL, PARAMETER  :: half = 0.5, one = 1.0, two = 2.0

CALL countr()
u = uu
const = u*sigsq
sum1 = u*const
u = two*u
j = ir
10 IF (.NOT.(j > 0)) GO TO 20
nj = n(j)
alj = alb(j)
ancj = anc(j)
x = u*alj
y = one - x
const = const + alj*(ancj/y + nj)/y
sum1 = sum1 + ancj*(x/y)**2
sum1 = sum1 + nj*(x**2/y + alog1(-x,.false.))
j = j - 1
GO TO 10
20 fn_val = exp1(-half*sum1)
cx = const
RETURN
END FUNCTION errbd

FUNCTION ctff(n, alb, anc, accx, upn) RESULT(fn_val)

!     Find CTFF so that P(QF > CTFF) < ACCX if UPN > 0;
!     P(QF < CTFF) < ACCX otherwise.

IMPLICIT NONE
INTEGER, INTENT(IN)   :: n(*)
REAL, INTENT(IN)      :: alb(*)
REAL, INTENT(IN)      :: anc(*)
REAL, INTENT(IN)      :: accx
REAL, INTENT(IN OUT)  :: upn
REAL                  :: fn_val

REAL     :: u1, u2, u, rb, const, c1, c2
! COMMON /qfcom/ aintl,ersm,pi,aln28,sigsq,almax,almin,amean,c,  &
!    icount,ir,ndtsrt,fail,lim
REAL, PARAMETER  :: zero = 0.0, one = 1.0, two = 2.0

u2 = upn
u1 = zero
c1 = amean
IF (.NOT.(u2 > zero)) GO TO 10
rb = almax
GO TO 20
10 rb = almin
20 rb = two*rb
u = u2/(one + u2*rb)
30 IF (.NOT.(errbd(n, alb, anc, u, c2) > accx)) GO TO 40
u1 = u2
c1 = c2
u2 = two*u2
u = u2/(one + u2*rb)
GO TO 30

40 u = (c1 - amean)/(c2 - amean)
50 IF (.NOT.(u < 0.9)) GO TO 80
u = (u1 + u2)/two
IF (.NOT.(errbd(n, alb, anc, u/(one + u*rb), const) > accx)) GO TO 60
u1 = u
c1 = const
GO TO 70

60 u2 = u
c2 = const
70 u = (c1 - amean)/(c2 - amean)
GO TO 50

80 fn_val = c2
upn = u2
RETURN
END FUNCTION ctff

FUNCTION truncn(n, alb, anc, uu, tausq) RESULT(fn_val)

!     Bound integration error due to truncation at U.

IMPLICIT NONE
INTEGER, INTENT(IN)  :: n(*)
REAL, INTENT(IN)     :: alb(*)
REAL, INTENT(IN)     :: anc(*)
REAL, INTENT(IN)     :: uu
REAL, INTENT(IN)     :: tausq
REAL                 :: fn_val

REAL     :: u
REAL     :: sum1, sum2, prod1, prod2, prod3, alj, ancj, x, y, err1, err2
INTEGER  :: j, nj, ns
! COMMON /qfcom/ aintl,ersm,pi,aln28,sigsq,almax,almin,amean,c,  &
!    icount,ir,ndtsrt,fail,lim
REAL, PARAMETER  :: zero = 0.0, quart = 0.25, half = 0.5, one = 1.0, two = 2.0

CALL countr()
u = uu
sum1 = zero
prod2 = zero
prod3 = zero
ns = 0
sum2 = (sigsq + tausq)*u**2
prod1 = two*sum2
u = two*u
j = 1

10 IF (.NOT.(j <= ir)) GO TO 40
alj = alb(j)
ancj = anc(j)
nj = n(j)
x = (u*alj)**2
sum1 = sum1 + ancj*x/(one + x)
IF (.NOT.(x > one)) GO TO 20
prod2 = prod2 + nj*LOG(x)
prod3 = prod3 + nj*alog1(x,.true.)
ns = ns + nj
GO TO 30

20 prod1 = prod1 + nj*alog1(x,.true.)
30 j = j + 1
GO TO 10

40 sum1 = half*sum1
prod2 = prod1 + prod2
prod3 = prod1 + prod3
x = exp1(-sum1 - quart*prod2)/pi
y = exp1(-sum1 - quart*prod3)/pi
IF (.NOT.(ns == 0)) GO TO 50
err1 = one
GO TO 60

50 err1 = x*two/ns
60 IF (.NOT.(prod3 > one)) GO TO 70
err2 = 2.5*y
GO TO 80

70 err2 = one
80 IF (.NOT.(err2 < err1)) GO TO 90
err1 = err2
90 x = half*sum2
IF (.NOT.(x <= y)) GO TO 100
err2 = one
GO TO 110

100 err2 = y/x
110 IF (.NOT.(err1 < err2)) GO TO 120
fn_val = err1
GO TO 130

120 fn_val = err2
130 RETURN
END FUNCTION truncn

SUBROUTINE findu (n, alb, anc, utx, accx)

!     Find U such that TRUNCN(U) < ACCX & TRUNCN(U / 1.2) > ACCX.

IMPLICIT NONE
INTEGER, INTENT(IN)   :: n(*)
REAL, INTENT(IN)      :: alb(*)
REAL, INTENT(IN)      :: anc(*)
REAL, INTENT(IN OUT)  :: utx
REAL, INTENT(IN)      :: accx

REAL     :: u, ut
INTEGER  :: i
! COMMON /qfcom/ aintl,ersm,pi,aln28,sigsq,almax,almin,amean,c,  &
!    icount,ir,ndtsrt,fail,lim
REAL, PARAMETER  :: divis(4) = (/ 2.0, 1.4, 1.2, 1.1 /)
REAL, PARAMETER  :: four = 4.0, zero = 0.0

ut = utx
u = ut/four
IF (.NOT.(truncn(n, alb, anc, u, zero) > accx)) GO TO 20
u = ut
10 IF (.NOT.(truncn(n, alb, anc, u, zero) > accx)) GO TO 40
ut = ut*four
u = ut
GO TO 10

20 ut = u
u = u/four
30 IF (.NOT.(truncn(n, alb, anc, u, zero) <= accx)) GO TO 40
ut = u
u = u/four
GO TO 30

40 DO  i = 1,4
  u = ut/divis(i)
  IF (.NOT.(truncn(n, alb, anc, u, zero) <= accx)) CYCLE
  ut = u
END DO
utx = ut
RETURN
END SUBROUTINE findu

SUBROUTINE integr (n, alb, anc, nterm, aintrv, tausq, main)

!     Carry out integration with NTERM terms, at interval AINTRV.
!     If not MAIN then multiply integrand by  1 - exp(-0.5 * TAUSQ * U**2).

IMPLICIT NONE
INTEGER, INTENT(IN)  :: n(*)
REAL, INTENT(IN)     :: alb(*)
REAL, INTENT(IN)     :: anc(*)
INTEGER, INTENT(IN)  :: nterm
REAL, INTENT(IN)     :: aintrv
REAL, INTENT(IN)     :: tausq
LOGICAL, INTENT(IN)  :: main

REAL      :: ainpi, u, sum1, sum2, sum3, x, y, z
INTEGER   :: k, j, nj
! COMMON /qfcom/ aintl,ersm,pi,aln28,sigsq,almax,almin,amean,c,  &
!    icount,ir,ndtsrt,fail,lim
REAL, PARAMETER  :: quart = 0.25, half = 0.5, one = 1.0, two = 2.0

ainpi = aintrv/pi
k = nterm
10 IF (.NOT.(k >= 0)) GO TO 50
u = (k + half)*aintrv
sum1 = -two*u*c
sum2 = ABS(sum1)
sum3 = -half*sigsq*u**2
j = ir

20 IF (.NOT.(j > 0)) GO TO 30
nj = n(j)
x = two*alb(j)*u
y = x**2
sum3 = sum3 - quart*nj*alog1(y,.true.)
y = anc(j)*x/(one + y)
z = nj*ATAN(x) + y
sum1 = sum1 + z
sum2 = sum2 + ABS(z)
sum3 = sum3 - half*x*y
j = j - 1
GO TO 20

30 x = ainpi*exp1(sum3)/u
IF (.NOT.(.NOT.main)) GO TO 40
x = x*(one - exp1(-half*tausq*u**2))
40 sum1 = SIN(half*sum1)*x
sum2 = half*sum2*x
aintl = aintl + sum1
ersm = ersm + sum2
k = k - 1
GO TO 10

50 RETURN
END SUBROUTINE integr

FUNCTION cfe(n, alb, anc, ith, x) RESULT(fn_val)

!     Coefficient of TAUSQ in error when convergence factor of
!     exp(-0.5 * TAUSQ * U**2) is used when df is evaluated at X.

IMPLICIT NONE
INTEGER, INTENT(IN)   :: n(*)
REAL, INTENT(IN)      :: alb(*)
REAL, INTENT(IN)      :: anc(*)
INTEGER, INTENT(OUT)  :: ith(*)
REAL, INTENT(IN)      :: x
REAL                  :: fn_val

REAL      :: axl, axl1, axl2, sxl, sum1, alj
INTEGER   :: j, k, it, itk
! COMMON /qfcom/ aintl,ersm,pi,aln28,sigsq,almax,almin,amean,c,  &
!    icount,ir,ndtsrt,fail,lim
REAL, PARAMETER  :: zero = 0.0, one = 1.0, four = 4.0, hundrd = 100.0

CALL countr()
IF (.NOT.(ndtsrt)) GO TO 10
CALL order (alb, ith)
10 axl = ABS(x)
sxl = SIGN(one,x)
sum1 = zero
j = ir

20 IF (.NOT.(j > 0)) GO TO 70
it = ith(j)
IF (.NOT.(alb(it)*sxl > zero)) GO TO 60
alj = ABS(alb(it))
axl1 = axl - alj*(n(it) + anc(it))
axl2 = alj/aln28
IF (.NOT.(axl1 > axl2)) GO TO 30
axl = axl1
GO TO 60

30 IF (.NOT.(axl > axl2)) GO TO 40
axl = axl2
40 sum1 = (axl - axl1)/alj
k = j - 1
50 IF (.NOT.(k > 0)) GO TO 70
itk = ith(k)
sum1 = sum1 + (n(itk) + anc(itk))
k = k - 1
GO TO 50

60 j = j - 1
GO TO 20

70 IF (.NOT.(sum1 > hundrd)) GO TO 80
fn_val = one
fail = .true.
GO TO 90
80 fn_val = 2**(sum1/four)/(pi*axl**2)
90 RETURN
END FUNCTION cfe

END MODULE Nonc_chisq


module compute_HSE_pres_module

  use multifab_module
  use ml_layout_module
  use probin_common_module, only: n_cells, grav
  use multifab_physbc_module
  use define_bc_module
  use bc_module

  implicit none

  private

  public :: compute_HSE_pres

contains

  ! initialize pressure using hydrostatic equilibrium
  ! assumes gravity is in the y-direction in 2D and 3D

  subroutine compute_HSE_pres(mla,sold,pold,dx,the_bc_tower)

    type(ml_layout), intent(in   ) :: mla
    type(multifab) , intent(in   ) :: sold(:)
    type(multifab) , intent(inout) :: pold(:)
    real(kind=dp_t), intent(in   ) :: dx(:,:)
    type(bc_tower) , intent(in   ) :: the_bc_tower

    ! local
    real(kind=dp_t), allocatable :: rhoavg(:), p0(:)
    real(kind=dp_t), allocatable :: rhosum_proc(:), rhosum(:)
    integer :: ncell_wide, ncell_hi, ng_s, ng_p

    integer :: i,dm,n,nlevs,lo(mla%dim),hi(mla%dim)
    real(kind=dp_t), pointer :: sp(:,:,:,:)
    real(kind=dp_t), pointer :: pp(:,:,:,:)

    type(bl_prof_timer),save :: bpt

    call build(bpt,"compute_HSE_pres")

    nlevs = mla%nlevel
    dm = mla%dim

    ! assumes gravity is in y-direction in 2D and 3D
    ncell_hi = n_cells(2)

    allocate(     rhoavg(0:ncell_hi-1))
    allocate(         p0(0:ncell_hi-1))
    allocate(rhosum_proc(0:ncell_hi-1))
    allocate(rhosum     (0:ncell_hi-1))

    rhosum_proc = 0.d0

    if (dm .eq. 2) then
       ncell_wide = n_cells(1)
    else
       ncell_wide = n_cells(1)*n_cells(3)
    end if

    ng_s = sold(1)%ng
    ng_p = pold(1)%ng

    ! compute 1D array of average density as a function of height
    ! need to use parallel reduce tricks

    do n=1,nlevs
       do i=1,nfabs(sold(n))
          sp => dataptr(sold(n),i)
          lo = lwb(get_box(sold(n),i))
          hi = upb(get_box(sold(n),i))
          select case (dm)
          case (2)
             call sum_rho_2d(sp(:,:,1,1),rhosum_proc,lo,hi,ng_s)
          case (3)
             call sum_rho_3d(sp(:,:,:,1),rhosum_proc,lo,hi,ng_s)
          end select
       end do

       call parallel_reduce(rhosum(:),rhosum_proc(:),MPI_SUM)

       ! compute rhobar by normalizing rhosum
       do i=0,n_cells(2)-1
          rhoavg(i) = rhosum(i)/dble(ncell_wide)
       end do

    end do

    ! compute 1D array of pressure, assuming p=0 in first cell
    ! and integrating dp/dz = rhoavg*g
    p0(0) = 0.d0
    do i=1,ncell_hi-1
       p0(i) = p0(i-1) + 0.5d0*dx(1,2)*(rhoavg(i)+rhoavg(i-1))*grav(2)
    end do

    ! copy the 1D array into the full pressure multifab
    do n=1,nlevs
       do i=1,nfabs(pold(n))
          pp => dataptr(pold(n),i)
          lo = lwb(get_box(pold(n),i))
          hi = upb(get_box(pold(n),i))
          select case (dm)
          case (2)
             call copy_p0_2d(pp(:,:,1,1),p0,lo,hi,ng_p)
          case (3)
             call copy_p0_3d(pp(:,:,:,1),p0,lo,hi,ng_p)
          end select
       end do
    end do

    ! presure ghost cells
    do n=1,nlevs
       call multifab_fill_boundary(pold(n))
       call multifab_physbc(pold(n),1,pres_bc_comp,1,the_bc_tower%bc_tower_array(n), &
                            dx_in=dx(n,:))
    end do

    deallocate(rhoavg,p0)

    call destroy(bpt)

  contains

    subroutine sum_rho_2d(rho,rhosum,lo,hi,ng_s)

      integer         , intent(in   ) :: lo(:), hi(:), ng_s
      real (kind=dp_t), intent(in   ) :: rho(lo(1)-ng_s:,lo(2)-ng_s:)
      real (kind=dp_t), intent(inout) :: rhosum(0:)

      ! local
      integer :: i,j

      do j=lo(2),hi(2)
         do i=lo(1),hi(1)
            rhosum(j) = rhosum(j) + rho(i,j)
         end do
      end do

    end subroutine sum_rho_2d

    subroutine sum_rho_3d(rho,rhosum,lo,hi,ng_s)

      integer         , intent(in   ) :: lo(:), hi(:), ng_s
      real (kind=dp_t), intent(in   ) :: rho(lo(1)-ng_s:,lo(2)-ng_s:,lo(3)-ng_s:)
      real (kind=dp_t), intent(inout) :: rhosum(0:)

      ! local
      integer :: i,j,k

      do j=lo(2),hi(2)
         do k=lo(3),hi(3)
         do i=lo(1),hi(1)
            rhosum(j) = rhosum(j) + rho(i,j,k)
         end do
         end do
      end do

    end subroutine sum_rho_3d

    subroutine copy_p0_2d(pres,p0,lo,hi,ng_p)

      integer         , intent(in   ) :: lo(:), hi(:), ng_p
      real (kind=dp_t), intent(inout) :: pres(lo(1)-ng_p:,lo(2)-ng_p:)
      real (kind=dp_t), intent(in   ) :: p0(0:)

      ! local
      integer :: i,j

      do j=lo(2),hi(2)
         do i=lo(1),hi(1)
            pres(i,j) = p0(j)
         end do
      end do

    end subroutine copy_p0_2d

    subroutine copy_p0_3d(pres,p0,lo,hi,ng_p)

      integer         , intent(in   ) :: lo(:), hi(:), ng_p
      real (kind=dp_t), intent(inout) :: pres(lo(1)-ng_p:,lo(2)-ng_p:,lo(3)-ng_p:)
      real (kind=dp_t), intent(in   ) :: p0(0:)

      ! local
      integer :: i,j,k

      do j=lo(2),hi(2)
         do k=lo(3),hi(3)
         do i=lo(1),hi(1)
            pres(i,j,k) = p0(j)
         end do
         end do
      end do

    end subroutine copy_p0_3d

  end subroutine compute_HSE_pres

end module compute_HSE_pres_module


! { dg-do compile }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/52093
!
! Contributed by Mohammad Rahmani
!

Program Main
 Implicit None
 Integer:: X(2,2)
 Integer:: X2(7:11,8:9)

 if (size((X)) /= 4) STOP 1
 if (any (Shape((X))  /= [2,2])) STOP 2
 if (any (lbound((X)) /= [1,1])) STOP 3
 if (any (ubound((X)) /= [2,2])) STOP 4

 if (size(X2) /= 10) STOP 5
 if (any (Shape(X2)  /= [5,2])) STOP 6
 if (any (lbound(X2) /= [7,8]))  STOP 7
 if (any (ubound(X2) /= [11,9])) STOP 8

 if (size((X2)) /= 10) STOP 9
 if (any (Shape((X2))  /= [5,2])) STOP 10
 if (any (lbound((X2)) /= [1,1])) STOP 11
 if (any (ubound((X2)) /= [5,2])) STOP 12
End Program Main

! { dg-final { scan-tree-dump-times "abort" 0 "original" } }


module wfmath_1d

  use iso_fortran_env, only: sp=>real32, dp=>real64, ip=>int32

  implicit none

  public :: wfmath_1d_proj
  interface wfmath_1d_proj
     module procedure wfmath_1d_proj_dp
     module procedure wfmath_1d_proj_sp
  end interface wfmath_1d_proj

  public :: wfmath_1d_iprod
  interface wfmath_1d_iprod
     module procedure wfmath_1d_iprod_dp
     module procedure wfmath_1d_iprod_sp
  end interface wfmath_1d_iprod

  public :: wfmath_1d_norm
  interface wfmath_1d_norm
     module procedure wfmath_1d_norm_dp
     module procedure wfmath_1d_norm_sp
  end interface wfmath_1d_norm

  public :: wfmath_1d_normalize
  interface wfmath_1d_normalize
     module procedure wfmath_1d_normalize_dp
     module procedure wfmath_1d_normalize_sp
  end interface wfmath_1d_normalize

  public :: wfmath_1d_expec_op
  interface wfmath_1d_expec_op
     module procedure wfmath_1d_expec_op_dp
     module procedure wfmath_1d_expec_op_sp
  end interface wfmath_1d_expec_op

  public :: wfmath_1d_stdev_op
  interface wfmath_1d_stdev_op
     module procedure wfmath_1d_stdev_op_dp
     module procedure wfmath_1d_stdev_op_sp
  end interface wfmath_1d_stdev_op

  public :: wfmath_1d_expec_grid
  interface wfmath_1d_expec_grid
     module procedure wfmath_1d_expec_grid_dp
     module procedure wfmath_1d_expec_grid_sp
  end interface wfmath_1d_expec_grid

  public :: wfmath_1d_stdev_grid
  interface wfmath_1d_stdev_grid
     module procedure wfmath_1d_stdev_grid_dp
     module procedure wfmath_1d_stdev_grid_sp
  end interface wfmath_1d_stdev_grid

contains

  complex(dp) function wfmath_1d_proj_dp(psi1_arr, psi2_arr, dgrid) &
       result(val)
    complex(dp), intent(in) :: psi1_arr(:), psi2_arr(:)
    real(dp), intent(in) :: dgrid

    include "./wfmath_1d_src/proj.src"
  end function wfmath_1d_proj_dp

  complex(sp) function wfmath_1d_proj_sp(psi1_arr, psi2_arr, dgrid) &
       result(val)
    complex(sp), intent(in) :: psi1_arr(:), psi2_arr(:)
    real(sp), intent(in) :: dgrid

    include "./wfmath_1d_src/proj.src"
  end function wfmath_1d_proj_sp

  complex(dp) function wfmath_1d_iprod_dp(psi1_arr, func_arr, psi2_arr, &
       dgrid) result(val)
    complex(dp), intent(in) :: psi1_arr(:), psi2_arr(:), func_arr(:)
    real(dp), intent(in) :: dgrid

    include "./wfmath_1d_src/iprod.src"
  end function wfmath_1d_iprod_dp

  complex(sp) function wfmath_1d_iprod_sp(psi1_arr, func_arr, psi2_arr, &
       dgrid) result(val)
    complex(sp), intent(in) :: psi1_arr(:), psi2_arr(:), func_arr(:)
    real(sp), intent(in) :: dgrid

    include "./wfmath_1d_src/iprod.src"
  end function wfmath_1d_iprod_sp

  real(dp) function wfmath_1d_norm_dp(psi_arr, dgrid) result(val)
    complex(dp), intent(in) :: psi_arr(:)
    real(dp), intent(in) :: dgrid

    integer(ip), parameter :: fp = dp

    include "./wfmath_1d_src/norm.src"
  end function wfmath_1d_norm_dp

  real(sp) function wfmath_1d_norm_sp(psi_arr, dgrid) result(val)
    complex(sp), intent(in) :: psi_arr(:)
    real(sp), intent(in) :: dgrid

    integer(ip), parameter :: fp = sp

    include "./wfmath_1d_src/norm.src"
  end function wfmath_1d_norm_sp

  subroutine wfmath_1d_normalize_dp(psi_arr, dgrid)
    complex(dp), intent(inout) :: psi_arr(:)
    real(dp), intent(in) :: dgrid

    integer(ip), parameter :: fp = dp

    include "./wfmath_1d_src/normalize.src"
  end subroutine wfmath_1d_normalize_dp

  subroutine wfmath_1d_normalize_sp(psi_arr, dgrid)
    complex(sp), intent(inout) :: psi_arr(:)
    real(sp), intent(in) :: dgrid

    integer(ip), parameter :: fp = sp

    include "./wfmath_1d_src/normalize.src"
  end subroutine wfmath_1d_normalize_sp

  real(dp) function wfmath_1d_expec_op_dp(psi_arr, op_arr, dgrid) &
       result(val)
    complex(dp), intent(in) :: psi_arr(:), op_arr(:)
    real(dp), intent(in) :: dgrid

    integer(ip), parameter :: fp = dp

    include "./wfmath_1d_src/expec_op.src"
  end function wfmath_1d_expec_op_dp

  real(sp) function wfmath_1d_expec_op_sp(psi_arr, op_arr, dgrid) &
       result(val)
    complex(sp), intent(in) :: psi_arr(:), op_arr(:)
    real(sp), intent(in) :: dgrid

    integer(ip), parameter :: fp = dp

    include "./wfmath_1d_src/expec_op.src"
  end function wfmath_1d_expec_op_sp

  real(dp) function wfmath_1d_stdev_op_dp(psi_arr, op_arr, dgrid) &
       result(val)
    complex(dp), intent(in) :: psi_arr(:), op_arr(:)
    real(dp), intent(in) :: dgrid

    integer(ip), parameter :: fp = dp

    include "./wfmath_1d_src/stdev_op.src"
  end function wfmath_1d_stdev_op_dp

  real(sp) function wfmath_1d_stdev_op_sp(psi_arr, op_arr, dgrid) &
       result(val)
    complex(sp), intent(in) :: psi_arr(:), op_arr(:)
    real(sp), intent(in) :: dgrid

    integer(ip), parameter :: fp = dp

    include "./wfmath_1d_src/stdev_op.src"
  end function wfmath_1d_stdev_op_sp

  real(dp) function wfmath_1d_expec_grid_dp(psi_arr, grid, dgrid) &
       result(val)
    complex(dp), intent(in) :: psi_arr(:)
    real(dp), intent(in) :: grid(:), dgrid

    integer(ip), parameter :: fp = dp

    include "./wfmath_1d_src/expec_grid.src"
  end function wfmath_1d_expec_grid_dp

  real(sp) function wfmath_1d_expec_grid_sp(psi_arr, grid, dgrid) &
       result(val)
    complex(sp), intent(in) :: psi_arr(:)
    real(sp), intent(in) :: grid(:), dgrid

    integer(ip), parameter :: fp = sp

    include "./wfmath_1d_src/expec_grid.src"
  end function wfmath_1d_expec_grid_sp

  real(dp) function wfmath_1d_stdev_grid_dp(psi_arr, grid, dgrid) &
       result(val)
    complex(dp), intent(in) :: psi_arr(:)
    real(dp), intent(in) :: grid(:), dgrid

    integer(ip), parameter :: fp = dp

    include "./wfmath_1d_src/stdev_grid.src"
  end function wfmath_1d_stdev_grid_dp

  real(sp) function wfmath_1d_stdev_grid_sp(psi_arr, grid, dgrid) &
       result(val)
    complex(sp), intent(in) :: psi_arr(:)
    real(sp), intent(in) :: grid(:), dgrid

    integer(ip), parameter :: fp = sp

    include "./wfmath_1d_src/stdev_grid.src"
  end function wfmath_1d_stdev_grid_sp

end module wfmath_1d