! **********************************************************************************
! *         ANALYTICAL SIZE AVERAGING PROCEDURE FOR SPHERICAL PARTICLES            *
! *    -------------------------------------------------------------------------   *
! *    Partial list of subroutines:                                                *
! *      DiffScatCrossSectAvrgSPH,         ScatteringMatrixSPH,                    *
! *      ExtendedScatteringMatrixSPH,      SijSCpqSPH,                             *
! *      AVSCTCOEF,                        AvCscatCextSPH,                         *
! *      AVSCTCOEF1,                       GeometryPars,                           *
! *      PDF                                                                       *
! **********************************************************************************
subroutine DiffScatCrossSectAvrgSPH (anorm, alphap, Ntheta, SS, normalized, Cext,   &
           Cscat, Qext, Qscat)
!-----------------------------------------------------------------------------------
! The routine computes the average differential scattering cross section in the    !
! azimuthal plane phi = 0. The incident wave propagates along the Z-axis of the    !
! global coordinate system.                                                        !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer       :: Ntheta, i
  real(O)       :: anorm, alphap, Cext, Cscat, Qext, Qscat, fact, ca, sa, ca2, sa2, &
                   theta, h, v
  complex(O)    :: SS(3,Ntheta)
  logical       :: normalized
!
  write (iDSCS,"(/,2x,'Results:',/)")
  write (iDSCS,"(2x,'Cross Sections and Efficiencies:')")
  write (iDSCS,"(2x,'average scattering cross section = ',1pe13.4,';')") Cscat
  write (iDSCS,"(2x,'average extinction cross section = ',1pe13.4,';')") Cext
  write (iDSCS,*)
  write (iDSCS,"(2x,'average scattering efficiency    = ',1pe13.4,';')") Qscat
  write (iDSCS,"(2x,'average extinction efficiency    = ',1pe13.4,';')") Qext
  write (iDSCS,*)
  write (iDSCS,"(2x,'Differential Scattering Cross Section:')")
  if (normalized) then
    write (iDSCS,"(2x, a, /, 2x, a, 9x, a, 8x, a, /)")                              &
   'normalized average  differential scattering cross section', 'theta',            &
   'parallel', 'perpendicular'
  else
    write (iDSCS,"(8x, a, /, 2x, a, 9x, a, 8x, a, /)")                              &
   'average differential scattering cross section', 'theta',                        &
   'parallel', 'perpendicular'
  end if
  ca   = cos(alphap)
  sa   = sin(alphap)
  ca2  = ca * ca
  sa2  = sa * sa
  fact = Pi * anorm * anorm
  fact = 1._O / fact
  do i = 1, Ntheta
    theta = real(i - 1,O) * 180._O / real(Ntheta - 1,O)
    h = real(SS(1,i),O) * ca2
    v = real(SS(3,i),O) * sa2
    if (normalized) then
      h = h * fact
      v = v * fact
    end if
    write (iDSCS,"(1x,f6.2,5x,1pe13.4,5x,1pe13.4)") theta, h, v
  end do
end subroutine DiffScatCrossSectAvrgSPH
! **********************************************************************************
subroutine ScatteringMatrixSPH (theta, Ntheta, ZE, Z)
!-----------------------------------------------------------------------------------
! The routine computes the scattering matrix Z at the scattering angle theta. ZE is!
! the extended scattering matrix and Ntheta is the number of scattering angles (at !
! which the extended scattering matrix is computed) in the azimuthale plane        !
! phi = 0.                                                                         !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: Ntheta
  real(O)    :: theta, ZE(4,Ntheta), Z(4,4)
!
  integer    :: i
  real(O)    :: Z11, Z12, Z33, Z34
  real(O),allocatable :: thetaV(:), ZV(:)
!
  allocate (thetaV(Ntheta), ZV(Ntheta))
  do i = 1, Ntheta
    thetaV(i) = real(i - 1,O) * Pi / real(Ntheta - 1,O)
  end do
  do i = 1, Ntheta
    ZV(i) = ZE(1,i)
  end do
  call Interp (Ntheta, thetaV, ZV, theta, Z11)
  do i = 1, Ntheta
    ZV(i) = ZE(2,i)
  end do
  call Interp (Ntheta, thetaV, ZV, theta, Z12)
  do i = 1, Ntheta
    ZV(i) = ZE(3,i)
  end do
  call Interp (Ntheta, thetaV, ZV, theta, Z33)
  do i = 1, Ntheta
    ZV(i) = ZE(4,i)
  end do
  call Interp (Ntheta, thetaV, ZV, theta, Z34)
  Z(1,1) =   Z11
  Z(1,2) =   Z12
  Z(1,3) =   0._O
  Z(1,4) =   0._O
  Z(2,1) =   Z12
  Z(2,2) =   Z11
  Z(2,3) =   0._O
  Z(2,4) =   0._O
  Z(3,1) =   0._O
  Z(3,2) =   0._O
  Z(3,3) =   Z33
  Z(3,4) =   Z34
  Z(4,1) =   0._O
  Z(4,2) =   0._O
  Z(4,3) = - Z34
  Z(4,4) =   Z33
  deallocate (thetaV, ZV)
end subroutine ScatteringMatrixSPH
! **********************************************************************************
subroutine ExtendedScatteringMatrixSPH (Ntheta, SS, ZE)
!-----------------------------------------------------------------------------------
! The routine computes the scattering matrix ZE, for all scattering angles. SS is  !
! the average size matrix and Ntheta is the number of scattering angles.           !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer    :: Ntheta, i
  real(O)    :: ZE(4,Ntheta)
  complex(O) :: SS(3,Ntheta)
  complex(O) :: S11SC11, S11SC22, S22SC22
!
  do i = 1, Ntheta
    S11SC11 = SS(1,i)
    S11SC22 = SS(2,i)
    S22SC22 = SS(3,i)
    ZE(1,i) = 0.5_O * real(S11SC11 + S22SC22,O)
    ZE(2,i) = 0.5_O * real(S11SC11 - S22SC22,O)
    ZE(3,i) = real (S11SC22,O)
    ZE(4,i) = aimag(S11SC22)
  end do
end subroutine ExtendedScatteringMatrixSPH
! **********************************************************************************
subroutine SijSCpqSPH (wavenumber, ind_ref, amin, amax, TypeDist, Npar, par, Cnst,  &
           Nrank, Nint, Ntheta, S, PrnProgress)
!-----------------------------------------------------------------------------------
! The routine computes the size average matrix <Spq Sp1q1*> by using an analytical !
! averaging procedure.                                                             !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer      :: TypeDist, Npar, Nrank, Nint, Ntheta
  real(O)      :: wavenumber, amin, amax, Cnst, par(Npar)
  complex(O)   :: ind_ref, S(3,Ntheta)
  logical      :: PrnProgress
!
  integer       :: i, j, n, nt, ml, m, mtl, mt, k, kt, Nmax, IdentifyIndex
  real(O)       :: wavenumber2, invwno
  complex(O)    :: fct, Ptt, Ptp, Ppt, Ppp, MTh, MPh, MThC, MPhC
  complex(O),allocatable :: M2inf(:,:), M3inf(:,:), A(:,:), B(:,:), C(:,:)
!
  Nmax = 3 * Nrank
  allocate (M2inf(Ntheta,Nmax), M3inf(Ntheta,Nmax))
  call MNinfiniteMatrix (1, Nrank, Nmax, Ntheta, M2inf, M3inf)
  allocate (A(Nrank,Nrank), B(Nrank,Nrank), C(Nrank,Nrank))
  call AVSCTCOEF (wavenumber, ind_ref, amin, amax, TypeDist, Npar, par, Cnst,       &
       Nrank, Nint, Nrank, A, B, C)
  wavenumber2 = wavenumber * wavenumber
  invwno      = 1._O / wavenumber2
  do j = 1,3
    do i = 1, Ntheta
      S(j,i) = zero
    end do
  end do
  do n = 1, Nrank
    if (PrnProgress) call write_progress (.false., n, Nrank)
    do nt = 1, Nrank
      do i = 1, Ntheta
        Ptt = zero
        Ptp = zero
        Ppt = zero
        Ppp = zero
        fct = im**(n - nt) * sqrt(real((2 * n + 1) * (2 * nt + 1),O))
        fct = fct * invwno
        do ml = 1, 2
          m = - 3 + 2 * ml
          k = IdentifyIndex (m, n, Nrank)
          do mtl = 1, 2
            mt = - 3 + 2 * mtl
            kt = IdentifyIndex (mt, nt, Nrank)
            MTh  = M2inf(i,k)
            MPh  = M3inf(i,k)
            MThC = conjg(M2inf(i,kt))
            MPhC = conjg(M3inf(i,kt))
            Ptt  = Ptt + m * mt * MTh * MThC * fct
            Ptp  = Ptp + im * m * MTh * MPhC * fct
            Ppt  = Ppt - im * mt * MPh * MThC * fct
            Ppp  = Ppp + MPh * MPhC * fct
          end do
        end do
        S(1,i) = S(1,i) + A(n,nt) * Ptt + C(n,nt) * Ptp +                           &
                          conjg(C(nt,n)) * Ppt + B(n,nt) * Ppp
        S(2,i) = S(2,i) + A(n,nt) * Ptp + C(n,nt) * Ptt +                           &
                          conjg(C(nt,n)) * Ppp + B(n,nt) * Ppt
        S(3,i) = S(3,i) + A(n,nt) * Ppp + C(n,nt) * Ppt +                           &
                          conjg(C(nt,n)) * Ptp + B(n,nt) * Ptt
      end do
    end do
  end do
  deallocate (M2inf, M3inf, A, B, C)
end subroutine SijSCpqSPH
! **********************************************************************************
subroutine AVSCTCOEF (wavenumber, ind_ref, amin, amax, TypeDist, Npar, par, Cnst,   &
           Nrank, Nint, NP, A, B, C)
  use parameters
  implicit none
  integer      :: TypeDist, Npar, Nrank, Nint, NP
  real(O)      :: wavenumber, amin, amax, Cnst, par(Npar)
  complex(O)   :: ind_ref, A(NP,NP), B(NP,NP), C(NP,NP)
!
  integer      :: n, nt, p
  real(O)      :: r, f, PDF
  real(O),allocatable    :: x(:), w(:)
  complex(O),allocatable :: cv(:)

  allocate (cv(2*Nrank))
  allocate (x(Nint), w(Nint))
  call Simpson (amin, amax, Nint, x, w)
  do n = 1, Nrank
    do nt = 1, Nrank
      A(n,nt) = zero
      B(n,nt) = zero
      C(n,nt) = zero
    end do
  end do
  do p = 1, Nint
    r = x(p)
    f = w(p) * Cnst * PDF(TypeDist, Npar, par, r)
    call coefficients_fg_m (wavenumber, r, ind_ref, 1, Nrank, Nrank, cv)
    do n = 1, Nrank
      do nt = 1, Nrank
        A(n,nt) = A(n,nt) + cv(n) * conjg(cv(nt)) * f
        B(n,nt) = B(n,nt) + cv(Nrank+n) * conjg(cv(Nrank+nt)) * f
        C(n,nt) = C(n,nt) + cv(n) * conjg(cv(Nrank+nt)) * f
      end do
    end do
  end do
  deallocate (cv, x, w)
end subroutine AVSCTCOEF
! **********************************************************************************
subroutine AvCscatCextSPH (wavenumber, snorm, ind_ref, amin, amax, TypeDist, Npar,  &
           par, Cnst, Nrank, Nint, Cext, Cscat, Qext, Qscat, AsymPar)
!-----------------------------------------------------------------------------------
! The routine computes the average cross sections, efficiencies and asymmetry      !
! parameter.                                                                       !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer      :: TypeDist, Npar, Nrank, Nint
  real(O)      :: wavenumber, amin, amax, Cnst, par(Npar), Cext, Cscat, Qext,       &
                  Qscat, AsymPar, snorm
  complex(O)   :: ind_ref
!
  integer       :: n
  real(O)       :: sum, fct, wavenumber2, invwno
  complex(O)    :: sum1, sum2
  real(O),allocatable    :: ccav(:)
  complex(O),allocatable :: cav(:), cav1(:), cav2(:)
!
  wavenumber2 = wavenumber * wavenumber
  invwno      = 1._O / wavenumber2
  allocate (cav(2*Nrank), ccav(2*Nrank), cav1(Nrank-1), cav2(Nrank))
  call AVSCTCOEF1 (wavenumber, ind_ref, amin, amax, TypeDist, Npar, par, Cnst,      &
       Nrank, Nint, cav, ccav, cav1, cav2)
  sum1 = zero
  sum  = 0._O
  sum2 = zero
  do n = 1, Nrank
    fct  = real(2 * n + 1,O)
    sum1 = sum1 + fct * (cav(n)  + cav(Nrank+n))
    sum  = sum  + fct * (ccav(n) + ccav(Nrank+n))
    fct  = fct / real(n * (n + 1),O)
    sum2 = sum2 + fct * cav2(n)
  end do
  Cext  = - 2._O * Pi * real(sum1,O) * invwno
  Cscat =   2._O * Pi * sum * invwno
  sum1 = zero
  do n = 1, Nrank - 1
    fct  = real(n * (n + 2),O) / real(n + 1,O)
    sum1 = sum1 + fct * cav1(n)
  end do
  AsymPar = 4._O * Pi * real(sum1 + sum2,O) * invwno / Cscat
  Qscat   = Cscat * wavenumber2 / snorm
  Qext    = Cext * wavenumber2 / snorm
  deallocate (cav, ccav, cav1, cav2)
end subroutine AvCscatCextSPH
! **********************************************************************************
subroutine AVSCTCOEF1 (wavenumber, ind_ref, amin, amax, TypeDist, Npar, par, Cnst,  &
           Nrank, Nint, cav, ccav, cav1, cav2)
  use parameters
  implicit none
  integer      :: TypeDist, Npar, Nrank, Nint
  real(O)      :: wavenumber, amin, amax, Cnst, par(Npar), ccav(2*Nrank)
  complex(O)   :: ind_ref, cav(2*Nrank), cav1(Nrank-1), cav2(Nrank)
!
  integer      :: n, p
  real(O)      :: r, f, PDF
  real(O),allocatable    :: x(:), w(:)
  complex(O),allocatable :: c(:)
!
  allocate (c(2*Nrank))
  allocate (x(Nint), w(Nint))
  call Simpson (amin, amax, Nint, x, w)
  do n = 1, 2*Nrank
    cav(n)  = zero
    ccav(n) = 0._O
  end do
  do n = 1, Nrank - 1
    cav1(n) = zero
  end do
  do n = 1, Nrank
    cav2(n) = zero
  end do
  do p = 1, Nint
    r = x(p)
    f = w(p) * Cnst * PDF(TypeDist, Npar, par, r)
    call coefficients_fg_m (wavenumber, r, ind_ref, 1, Nrank, Nrank, c)
    do n = 1, 2*Nrank
      cav (n) = cav(n)  + c(n) * f
      ccav(n) = ccav(n) + abs(c(n)) * abs(c(n)) * f
    end do
    do n = 1, Nrank - 1
      cav1(n) = cav1(n) + (c(n) * conjg(c(n+1)) +                                   &
      c(Nrank+n) * conjg(c(Nrank+n+1))) * f
    end do
    do n = 1, Nrank
      cav2(n) = cav2(n) + c(n) * conjg(c(Nrank+n)) * f
    end do
  end do
  deallocate (c, x, w)
end subroutine AVSCTCOEF1
! **********************************************************************************
subroutine GeometryPars (amin, amax, TypeDist, Npar, par, Nint, Cnst, AvrgArea,     &
           EffRadius, AvrgRadius, AvrgVolume, VWAvrgRadius, EffVar)
  use parameters
  implicit none
  integer      :: TypeDist, Npar, Nint
  real(O)      :: amin, amax, par(Npar), Cnst, AvrgArea, EffRadius, AvrgRadius,     &
                  AvrgVolume, VWAvrgRadius, EffVar
!
  integer      :: p
  real(O)      :: r, r2, r3, r4, dr2, sum, sum1, sum2, sum3, sum4, PDF
  real(O),allocatable    :: x(:), w(:)
!
  allocate (x(Nint), w(Nint))
  call Simpson (amin, amax, Nint, x, w)
  sum  = 0._O
  sum1 = 0._O
  sum2 = 0._O
  sum3 = 0._O
  sum4 = 0._O
  do p = 1, Nint
    r    = x(p)
    r2   = r  * r
    r3   = r2 * r
    r4   = r2 * r2
    sum  = sum  + w(p) * PDF(TypeDist, Npar, par, r)
    sum1 = sum1 + w(p) * r  * PDF(TypeDist, Npar, par, r)
    sum2 = sum2 + w(p) * r2 * PDF(TypeDist, Npar, par, r)
    sum3 = sum3 + w(p) * r3 * PDF(TypeDist, Npar, par, r)
    sum4 = sum4 + w(p) * r4 * PDF(TypeDist, Npar, par, r)
  end do
  Cnst = 1._O / sum
  AvrgArea     = Pi * sum2 * Cnst
  EffRadius    = Pi * sum3 * Cnst / AvrgArea
  AvrgRadius   = sum1 * Cnst
  AvrgVolume   = 4._O * Pi * sum3 * Cnst / 3._O
  VWAvrgRadius = 4._O * Pi * sum4 * Cnst / (3._O * AvrgVolume)
  sum  = 0._O
  do p = 1, Nint
    r   = x(p)
    r2  = r * r
    dr2 = (r - EffRadius) * (r - EffRadius)
    sum = sum + w(p) * dr2 * r2 * PDF(TypeDist, Npar, par, r)
  end do
  EffVar = Pi * sum * Cnst / (AvrgArea * EffRadius * EffRadius)
  deallocate (x, w)
end subroutine GeometryPars
!***********************************************************************************
function PDF (TypeDist, Npar, par, a) result(func)
  use parameters
  implicit none
  integer,intent(in) :: TypeDist, Npar
  real(O),intent(in) :: par(Npar), a
  real(O) :: func
!
  real(O) :: alpha, gamma, ac, ag, sg, ag1, sg1, lnf, lnf1
!
  select case (TypeDist)
  case (1)
!   --- modified gamma distribution ---
    alpha = par(1)
    gamma = par(2)
    ac    = par(3)
    lnf   = alpha * log(a) - alpha * (a / ac)**gamma / gamma
    func  = exp(lnf)
  case (2)
!   --- log normal distribution ---
    ag    = par(1)
    sg    = par(2)
    lnf   = - log(a) - 0.5_O * (log(a/ag) / log(sg))**2
    func  = exp(lnf)
  case (3)
!   --- gamma distribution ---
    alpha = par(1)
    gamma = par(2)
    lnf   = (1._O - 3._O * gamma) * log(a) / gamma - a / alpha / gamma
    func  = exp(lnf)
  case (4)
!   --- power law distribution ---
    alpha =   par(1)
    lnf   = - alpha * log(a)
    func  =   exp(lnf)
  case (5)
!   --- modified bimodal log normal distribution ---
    ag    = par(1)
    sg    = par(2)
    ag1   = par(3)
    sg1   = par(4)
    gamma = par(5)
    lnf   = - 4._O * log(a) - 0.5_O * (log(a/ag)  / log(sg))**2
    lnf1  = - 4._O * log(a) - 0.5_O * (log(a/ag1) / log(sg1))**2
    func  = exp(lnf) + gamma * exp(lnf1)
  end select
end function PDF


!======================================================================================================================
!> @file        global.f90
!> @brief       This file contains a module of global parameters for the example problem of PaScaL_TDMA.
!> @details     The target example problem is the three-dimensional(3D) time-dependent heat conduction problem
!>              in a unit cube domain applied with the boundary conditions of vertically constant temperature
!>              and horizontally periodic boundaries.
!> @author
!>              - Kiha Kim (k-kiha@yonsei.ac.kr), Department of Computational Science & Engineering, Yonsei University
!>              - Ji-Hoon Kang (jhkang@kisti.re.kr), Korea Institute of Science and Technology Information
!>              - Jung-Il Choi (jic@yonsei.ac.kr), Department of Computational Science & Engineering, Yonsei University
!>
!> @date        June 2019
!> @version     1.0
!> @par         Copyright
!>              Copyright (c) 2019 Kiha Kim and Jung-Il choi, Yonsei University and
!>              Ji-Hoon Kang, Korea Institute of Science and Technology Information, All rights reserved.
!> @par         License
!>              This project is release under the terms of the MIT License (see LICENSE in )
!======================================================================================================================

!>
!> @brief       Module for global parameters.
!> @details     This global module has simulation parameters and a subroutine to initialize the parameters.
!>
module global
    implicit none
    double precision, parameter :: PI = acos(-1.d0)

    ! Physical parameters
    double precision :: Pr  !< Prandtl number
    double precision :: Ra  !< Reyleigh number

    ! Iteration steps
    integer :: Tmax             !< Maximum number of iteration steps

    ! Computational size for the physical domain and time discretization
    !> @{ Grid numbers in each direction
    integer :: nx,ny,nz
    !> @}
    !> @{ Grid numbers minus 1 in each direction
    integer :: nxm,nym,nzm
    !> @}
    !> @{ Grid numbers plus 1 in each direction
    integer :: nxp,nyp,nzp
    !> @}
    double precision :: dt                  !< Length of time step
    double precision :: dtStart             !< Initial dt
    double precision :: tStart              !< Initial simulation time

    ! Physical size of the computational domain
    !> @{ Lengths of the physical domain
    double precision :: lx, ly, lz
    !> @}
    !> @{ Discretized grid lengths of the physical domain
    double precision :: dx, dy, dz
    !> @}

    ! Boundary conditions of the hot and cold walls and related parameters
    double precision :: theta_cold              !< Boundary temperature of cold wall
    double precision :: theta_hot               !< Boundary temperature of hot wall
    double precision :: alphaG                  !< Thermal expansion coefficient x gravitational acceleration
    double precision :: nu                      !< Kinematic viscosity
    double precision :: Ct                      !< Thermal diffusivity

    contains
    !>
    !> @brief       Assign global parameters.
    !> @param       np_dim      Number of MPI processes in 3D topology
    !>
    subroutine global_inputpara(np_dim)
        implicit none
        integer, intent(out) :: np_dim(0:2)

        integer :: npx, npy, npz   ! Variables to read number of processes in 3D topology

        ! Namelist variables for file input
        namelist /meshes/ nx, ny, nz
        namelist /procs/ npx, npy, npz
        namelist /time/ tmax

        open (unit = 1, file = "PARA_INPUT.inp")
            read (1, meshes)
            read (1, procs)
            read (1, time)
        close (1)

        np_dim(0) = npx
        np_dim(1) = npy
        np_dim(2) = npz

        ! Physical parameters
        Pr = 5.0d0; Ra = 2.d+2

        ! Computational size for the physical domain and time discretization
        nx = nx+1; ny = ny+1; nz = nz+1
        nxm = nx-1; nym = ny-1; nzm = nz-1
        nxp = nx+1; nyp = ny+1; nzp = nz+1

        dtStart = 5.0D-3; tStart = 0.d0

        ! Physical size of the computational domain
        lx = 1.0d0; ly = 1.0d0; lz = 1.0d0

        ! Boundary conditions of the hot and cold walls and related parameters
        theta_cold = -1.d0; theta_hot = 2.d0 + theta_cold
        alphaG = 1.d0; nu = 1.d0/sqrt(Ra/(alphaG*Pr*ly**3.*(theta_hot-theta_cold)))
        Ct = nu/Pr

    end subroutine global_inputpara

end module global


C     *****************************************************************
C     *****************************************************************

      subroutine comphapp(n,m,rho,equatn)

      implicit none

C     SCALAR ARGUMENTS
      integer m,n

C     ARRAY ARGUMENTS
      logical equatn(m)
      double precision rho(m)

C     This subroutine computes an approximation H of the Hessian of the
C     Augmented Lagrangian following a very simple idea: "discard the
C     second order terms and then correct the remaining matrix in order
C     to satisfy a secant equation".
C
C     Hence, H takes the form
C
C     H = B + S + rho A^t A,
C
C     where S is the spectral correction of (rho A^t A) and B is
C     the BFGS correction of (S + rho A^t A). More specifically,
C
C     S = hlspg I,
C
C     where
C
C     hlspg = max(lspgmi, min(lspgma, s^t (y - rho A^t A s) / s^t s)),
C
C     D = S + rho A^t A,
C
C     and
C
C     B = [ y y ^t / ( y^t s ) ] - [ D s ( D s )^t / ( s^t D s ) ].
C
C     Note that this subroutine does not compute matrix H explicitly,
C     but computes some quantities that will be used later to compute
C     the product of H by a vector p.
C
C     The quantities computed by this subroutine are:
C
C     (a) hlspg = s^t (y - rho A^t A s) / (s^t s)
C
C     (b) hds = D s = ( hlspg I + rho A^t A ) s, and
C
C     (c) hstds = <s,hds>.

      include "dim.par"
      include "algconst.par"
      include "graddat.inc"
      include "sydat.inc"
      include "happdat.inc"

C     LOCAL SCALARS
      integer i,j
      double precision ats

C     ------------------------------------------------------------------
C     Compute hds = rho A^t A s
C     ------------------------------------------------------------------

      do i = 1,n
          hds(i) = 0.0d0
      end do

      do j = 1,m

          if ( equatn(j) .or. dpdc(j) .gt. 0.0d0 ) then

C             COMPUTE THE INNER PRODUCT <a,s>
              ats = 0.0d0
              do i = jcsta(j),jcsta(j) + jclen(j) - 1
                  ats = ats + jcval(i) * s(jcvar(i))
              end do

              ats = ats * rho(j)

C             ADD rho * ats * a
              do i = jcsta(j),jcsta(j) + jclen(j) - 1
                  hds(jcvar(i)) = hds(jcvar(i)) + ats * jcval(i)
              end do

          end if

      end do

      hstds = 0.0d0
      do i = 1,n
          hstds = hstds + s(i) * hds(i)
      end do

C     ------------------------------------------------------------------
C     Compute hlspg = s^t (y - rho A^t A s) / (s^t s)
C     ------------------------------------------------------------------

      if ( sty - hstds .le. 0.0d0 ) then
          hlspg = lspgmi
      else
          hlspg = max( lspgmi, min( (sty - hstds) / sts, lspgma ) )
      end if

      do i = 1,n
          hds(i) = hds(i) + hlspg * s(i)
      end do

      hstds = hstds + hlspg * sts

      end

C     *****************************************************************
C     *****************************************************************

      subroutine applyhapp(n,m,rho,equatn,goth,p,hp)

      implicit none

C     SCALAR ARGUMENTS
      logical goth
      integer m,n

C     ARRAY ARGUMENTS
      logical equatn(m)
      double precision hp(n),p(n),rho(m)

C     This subroutine computes the product of the matrix computed by
C     subroutine comphapp times vector p.

      include "dim.par"
      include "machconst.inc"
      include "graddat.inc"
      include "sydat.inc"
      include "itetyp.inc"
      include "happdat.inc"

C     LOCAL SCALARS
      integer i,j
      double precision atp,c1,c2,ptds,pty

C     ------------------------------------------------------------------
C     Compute Hessian approximation
C     ------------------------------------------------------------------

      if ( .not. goth ) then
          goth = .true.
          call comphapp(n,m,rho,equatn)
      end if

C     ------------------------------------------------------------------
C     Compute ( hlspg I ) p
C     ------------------------------------------------------------------

      do i = 1,n
          hp(i) = hlspg * p(i)
      end do

C     ------------------------------------------------------------------
C     Add ( rho A^T A ) p
C     ------------------------------------------------------------------

      do j = 1,m

          if ( equatn(j) .or. dpdc(j) .gt. 0.0d0 ) then

C             COMPUTE THE INNER PRODUCT <a,p>
              atp = 0.0d0
              do i = jcsta(j),jcsta(j) + jclen(j) - 1
                  atp = atp + jcval(i) * p(jcvar(i))
              end do

              atp = atp * rho(j)

C             ADD rho * atp * a
              do i = jcsta(j),jcsta(j) + jclen(j) - 1
                  hp(jcvar(i)) = hp(jcvar(i)) + atp * jcval(i)
              end do

          end if

      end do

C     ------------------------------------------------------------------
C     Add B p,
C     where B = [ y y ^t / ( y^t s ) ] - [ D s ( D s )^t / ( s^t D s ) ]
C     ------------------------------------------------------------------

      if ( sameface .and. sty .gt. macheps12 * seucn * yeucn ) then

          pty = 0.0d0
          ptds = 0.0d0
          do i = 1,n
              pty = pty + p(i) * y(i)
              ptds = ptds + p(i) * hds(i)
          end do

          c1 = pty / sty
          c2 = ptds / hstds
          do i = 1,n
              hp(i) = hp(i) + c1 * y(i) - c2 * hds(i)
          end do

      end if

      end

C     *****************************************************************
C     *****************************************************************

      subroutine comphpre(n,m,rho,equatn)

      implicit none

C     SCALAR ARGUMENTS
      integer m,n

C     ARRAY ARGUMENTS
      logical equatn(m)
      double precision rho(m)

C     Consider the preconditioner
C
C         P = Q + E + diag(rho A^t A)
C
C     for matrix
C
C         H = B + S + rho A^t A,
C
C     where E is the spectral correction of diag(rho A^t A) and Q is
C     the BFGS correction of (E + diag(rho A^t A)), while S and B are
C     the spectral and BFGS corrections of matrix (rho A^t A),
C     respectively.
C
C     This subroutine computes:
C
C     (a) pdiag = diag(rho A^t A),
C
C     (b) plspg such that E = plspg I,
C
C     (c) psmdy = s - D^-1 y, where D = E + diag(rho A^t A), and
C
C     (d) the inner product psmdty = <psmdy,y>.
C
C     These quantities will be used later, in subroutine applyp, to
C     compute z = P^{-1} r.

      include "dim.par"
      include "machconst.inc"
      include "algconst.par"
      include "graddat.inc"
      include "sydat.inc"
      include "itetyp.inc"
      include "hpredat.inc"

C     LOCAL SCALARS
      integer i,j
      double precision sttmp

C     ------------------------------------------------------------------
C     Compute diag( rho A^t A )
C     ------------------------------------------------------------------

      do i = 1,n
          pdiag(i) = 0.0d0
      end do

      do j = 1,m
          if ( equatn(j) .or. dpdc(j) .gt. 0.0d0 ) then
              do i = jcsta(j),jcsta(j) + jclen(j) - 1
                  pdiag(jcvar(i)) =
     +            pdiag(jcvar(i)) + rho(j) * jcval(i) ** 2
              end do
          end if
      end do

C     ------------------------------------------------------------------
C     Compute plspg = s^t (y - diag( rho A^t A ) s) / (s^t s)
C     ------------------------------------------------------------------

      sttmp = 0.0d0
      do i = 1,n
          sttmp = sttmp + pdiag(i) * s(i) ** 2
      end do

      if ( sty - sttmp .le. 0.0d0 ) then
          plspg = lspgmi
      else
          plspg = max( lspgmi, min( ( sty - sttmp ) / sts, lspgma ) )
      end if

C     ------------------------------------------------------------------
C     Compute the BFGS correction Q of ( E + diag( rho A^t A ) )
C
C     Q = [ (s - D^-1 y) s^t + s (s - D^-1 y)^t ] / s^t y -
C         [ <s - D^-1 y, y> s s^t ] / (s^t y)^2,
C
C     where D = ( E + diag( rho A^t A ) )
C     ------------------------------------------------------------------

      if ( sameface .and. sty .gt. macheps12 * seucn * yeucn ) then

          psmdyty = 0.0d0
          do i = 1,n
              psmdy(i) = s(i) - y(i) / ( plspg + pdiag(i) )
              psmdyty = psmdyty + psmdy(i) * y(i)
          end do

      end if

      end

C     *****************************************************************
C     *****************************************************************

      subroutine applyhpre(n,m,rho,equatn,gotp,r,z)

      implicit none

C     SCALAR ARGUMENTS
      logical gotp
      integer m,n

C     ARRAY ARGUMENTS
      logical equatn(m)
      double precision r(n),rho(m),z(n)

C     This subroutine computes the product of the inverse of the matrix
C     computed by subroutine comphpre times vector r, i.e., z = P^{-1} r.

      include "dim.par"
      include "machconst.inc"
      include "sydat.inc"
      include "itetyp.inc"
      include "hpredat.inc"

C     LOCAL SCALARS
      integer i
      double precision c1,c2,psmdytr,str

C     ------------------------------------------------------------------
C     Compute P
C     ------------------------------------------------------------------

      if ( .not. gotp ) then
          gotp = .true.
          call comphpre(n,m,rho,equatn)
      end if

C     ------------------------------------------------------------------
C     Compute ( E + diag( rho A^T A ) )^{-1} r
C     ------------------------------------------------------------------

      do i = 1,n
          z(i) = r(i) / ( plspg + pdiag(i) )
      end do

C     ------------------------------------------------------------------
C     Add Q^{-1} r, where
C
C     Q^{-1} = [ (s - D^-1 y) s^t + s (s - D^-1 y)^t ] / s^t y -
C              [ <s - D^-1 y, y> s s^t ] / (s^t y)^2
C
C     and D = ( E + diag( rho A^T A ) )
C     ------------------------------------------------------------------

      if ( sameface .and. sty .gt. macheps12 * seucn * yeucn ) then

          str = 0.0d0
          psmdytr = 0.0d0
          do i = 1,n
              str = str + s(i) * r(i)
              psmdytr = psmdytr + psmdy(i) * r(i)
          end do

          c1 = str / sty
          c2 = psmdytr / sty - psmdyty * str / sty ** 2

          do i = 1,n
              z(i) = z(i) + c1 * psmdy(i) + c2 * s(i)
          end do

      end if

      end


*DECK DXPNRM
      SUBROUTINE DXPNRM (NU1, NU2, MU1, MU2, PQA, IPQA, IERROR)
C***BEGIN PROLOGUE  DXPNRM
C***SUBSIDIARY
C***PURPOSE  To compute the values of Legendre functions for DXLEGF.
C            This subroutine transforms an array of Legendre functions
C            of the first kind of negative order stored in array PQA
C            into normalized Legendre polynomials stored in array PQA.
C            The original array is destroyed.
C***LIBRARY   SLATEC
C***CATEGORY  C3A2, C9
C***TYPE      DOUBLE PRECISION (XPNRM-S, DXPNRM-D)
C***KEYWORDS  LEGENDRE FUNCTIONS
C***AUTHOR  Smith, John M., (NBS and George Mason University)
C***ROUTINES CALLED  DXADJ
C***REVISION HISTORY  (YYMMDD)
C   820728  DATE WRITTEN
C   890126  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  DXPNRM
      DOUBLE PRECISION C1,DMU,NU,NU1,NU2,PQA,PROD
      DIMENSION PQA(*),IPQA(*)
C***FIRST EXECUTABLE STATEMENT  DXPNRM
      IERROR=0
      L=(MU2-MU1)+(NU2-NU1+1.5D0)
      MU=MU1
      DMU=MU1
      NU=NU1
C
C         IF MU .GT.NU, NORM P =0.
C
      J=1
  500 IF(DMU.LE.NU) GO TO 505
      PQA(J)=0.D0
      IPQA(J)=0
      J=J+1
      IF(J.GT.L) RETURN
C
C        INCREMENT EITHER MU OR NU AS APPROPRIATE.
C
      IF(MU2.GT.MU1) DMU=DMU+1.D0
      IF(NU2-NU1.GT..5D0) NU=NU+1.D0
      GO TO 500
C
C         TRANSFORM P(-MU,NU,X) INTO NORMALIZED P(MU,NU,X) USING
C              NORM P(MU,NU,X)=
C                 SQRT((NU+.5)*FACTORIAL(NU+MU)/FACTORIAL(NU-MU))
C                              *P(-MU,NU,X)
C
  505 PROD=1.D0
      IPROD=0
      K=2*MU
      IF(K.LE.0) GO TO 520
      DO 510 I=1,K
      PROD=PROD*SQRT(NU+DMU+1.D0-I)
  510 CALL DXADJ(PROD,IPROD,IERROR)
      IF (IERROR.NE.0) RETURN
  520 DO 540 I=J,L
      C1=PROD*SQRT(NU+.5D0)
      PQA(I)=PQA(I)*C1
      IPQA(I)=IPQA(I)+IPROD
      CALL DXADJ(PQA(I),IPQA(I),IERROR)
      IF (IERROR.NE.0) RETURN
      IF(NU2-NU1.GT..5D0) GO TO 530
      IF(DMU.GE.NU) GO TO 525
      PROD=SQRT(NU+DMU+1.D0)*PROD
      IF(NU.GT.DMU) PROD=PROD*SQRT(NU-DMU)
      CALL DXADJ(PROD,IPROD,IERROR)
      IF (IERROR.NE.0) RETURN
      MU=MU+1
      DMU=DMU+1.D0
      GO TO 540
  525 PROD=0.D0
      IPROD=0
      MU=MU+1
      DMU=DMU+1.D0
      GO TO 540
  530 PROD=SQRT(NU+DMU+1.D0)*PROD
      IF(NU.NE.DMU-1.D0) PROD=PROD/SQRT(NU-DMU+1.D0)
      CALL DXADJ(PROD,IPROD,IERROR)
      IF (IERROR.NE.0) RETURN
      NU=NU+1.D0
  540 CONTINUE
      RETURN
      END


! =============================================================================
! This module contains global parameters that stay constant throughout a
! simulation.
! =============================================================================
module parameters
    use options, only : allow_larger_anisotropy, parcel
    use constants
    implicit none

    ! mesh spacing
    double precision :: dx(2)

    ! inverse mesh spacing
    double precision :: dxi(2)

    ! grid cell volume, really area in 2D:
    double precision :: vcell

    ! inverse grid cell volume
    double precision :: vcelli

    ! number of grid cells in each dimension
    integer :: nx, nz

    ! total number of grid cells
    integer :: ncell

    ! inverse of total number of grid cells
    double precision :: ncelli

    ! total number of grid points
    integer :: ngrid

    ! inverse of total number of grid points
    double precision :: ngridi

    ! domain size
    double precision :: extent(2)

    ! domain centre
    double precision :: center(2)

    ! domain half widths values
    double precision :: hl(2)

    double precision :: hli(2)

    ! domain origin
    double precision :: lower(2)

    ! domain upper boundary
    double precision :: upper(2)

    ! minimum volume
    double precision :: vmin

    ! maximum volume
    double precision :: vmax

    ! maximum number of allowed parcels
    integer :: max_num_parcels

    contains

    ! Update all parameters according to the
    ! user-defined global options.
    subroutine update_parameters

        upper = lower + extent

        dx = extent / dble((/nx, nz/))
        dxi = one / dx;

        if (max(dxi(1) * dx(2), dxi(2) * dx(1)) > two) then
            print *, '**********************************************************************'
            print *, '*                                                                    *'
            print *, '*   Warning: A mesh spacing ratio of more than 2 is not advisable!   *'
            print *, '*                                                                    *'
            print *, '**********************************************************************'

            if (.not. allow_larger_anisotropy) then
                stop
            endif
        endif

        vcell = product(dx)
        vcelli = one / vcell

        ncell = nx * nz
        ncelli = one / dble(ncell)

        ! due to x periodicity it is only nx
        ngrid = nx * (nz + 1)
        ngridi = one / dble(ngrid)

        ! domain
        center = f12 * (lower + upper)
        hl = extent / two
        hli = one / hl

        vmin = vcell / parcel%min_vratio
        vmax = vcell / parcel%max_vratio

        max_num_parcels = int(nx * nz * parcel%min_vratio * parcel%size_factor)

    end subroutine update_parameters
end module parameters


! libRQZ
! author: daan. camps@cs.kuleuven.be
! Description:
!   Change poles in real block-Hessenberg pairs
! ___________________________________________________________________
module d_setpoles

use u_parameters
use u_activeparts
use d_ctransformations
use d_computepoles
use d_memorymgmt
use d_swappoles12
use d_swappoles22
use d_deflations

implicit none
private
public d_first_single_pole, d_first_double_pole, &
       d_last_single_pole, d_last_double_pole, &
       d_first_double_to_inf, d_last_double_to_inf, &
       d_first_m_poles, d_last_m_poles

contains

  subroutine d_first_single_pole(alpha, beta, A, B, compAB, apC, apT, &
                                 Q, compQ, qcol)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Sets the pole of (A,B) in the first position of the current
  ! active part apC to alpha / beta.
  ! It is assumed that the first pole is currently a single pole.
  ! If compAB is true, the complete pencil is updated based on apT,
  ! if not only the active part apC of the pencil is updated
  ! If compQ is true, the transformation is also applied to
  ! the relevant two columns of Q specified by qcol
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! alpha   double [IN]
  !           Defines the new first pole: alpha/beta
  ! beta    double [IN]
  !           Defines the new first pole: alpha/beta
  ! A       double array [INOUT]
  !           Upper block-Hessenberg matrix A
  ! B       double array [INOUT]
  !           Upper block-Hessenberg matrix B
  ! compAB  boolean [IN]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the current active part
  ! apC     type(tAp) [IN]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Q       complex double array [INOUT]
  !           Unitary equivalence matrix Q
  ! compQ   boolean [IN]
  !           If true, the left Schur vectors are updated
  ! qcol    integer [IN]
  !           Start index of the columns of Q that are updated:
  !              qcol, qcol+1
  !___________________________________________________________________________
  ! last edit: September 5, 2018
    integer, intent(in)               ::  qcol
    real(kind=dp), intent(inout)      ::  A(:,:), B(:,:)
    real(kind=dp), intent(in)         ::  alpha, beta
    logical, intent(in)               ::  compQ, compAB
    real(kind=dp), intent(inout)      ::  Q(:,:)
    type(tAp), pointer, intent(in)    ::  apC, apT

    real(kind=dp)                     :: v(2), c, s, r
    integer,pointer                   :: cstrt, cstp, tstrt, tstp
    integer                           :: LDQ
    real(kind=dp), external           :: ddot

    call d_getLeadingDim(LDQ,Q)
    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    ! Compute and normalize the vector of interest
    v = A(cstrt+1:cstrt+2,cstrt+1) * beta - B(cstrt+1:cstrt+2,cstrt+1) * alpha
    s = ddot(2,v,1,v,1)
    v = v / sqrt(abs(s))

    ! Update pair and equivalence
    if (abs(v(2)) .gt. mp) then
      call d_compute_ct(v(1),v(2),c,s,r)
      if (compAB) then
        call d_apply_ct_l(A(cstrt+1,cstrt+1:tstp),A(cstrt+2,cstrt+1:tstp),c,s)
        call d_apply_ct_l(B(cstrt+1,cstrt+1:tstp),B(cstrt+2,cstrt+1:tstp),c,s)
      else
        call d_apply_ct_l(A(cstrt+1,cstrt+1:cstp),A(cstrt+2,cstrt+1:cstp),c,s)
        call d_apply_ct_l(B(cstrt+1,cstrt+1:cstp),B(cstrt+2,cstrt+1:cstp),c,s)
      endif

      if (compQ) then
        call d_apply_ct_r(Q(1:LDQ,qcol),Q(1:LDQ,qcol+1),c,-s)
      endif
    end if
  end subroutine

  subroutine d_first_double_pole(mu, A, B, compAB, apC, apT, Q, compQ, qcol, &
                Z, compZ, zcol)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Sets the pole of (A,B) in the first and second position of the current
  ! active part apC to mu and conjg(mu).
  ! It is assumed that the first and second pole are currently
  ! either two consecutive single poles or a double pole.
  ! If compAB is true, the complete pencil is updated based on apT,
  ! if not only the active part apC of the pencil is updated
  ! If compQ is true, the transformation is also applied to
  ! the relevant two columns of Q specified by qcol
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! mu      complex double [IN]
  !           Defines the new first and second pole: mu and conjg(mu)
  ! A       double array [INOUT]
  !           Upper block-Hessenberg matrix A
  ! B       double array [INOUT]
  !           Upper block-Hessenberg matrix B
  ! compAB  boolean [IN]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the current active part
  ! apC     type(tAp) [IN]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Q       complex double array [INOUT]
  !           Unitary equivalence matrix Q
  ! compQ   boolean [IN]
  !           If true, the left Schur vectors are updated
  ! qcol    integer [IN]
  !           Start index of the columns of Q that are updated:
  !              qcol, qcol+1
  !___________________________________________________________________________
  ! last edit: January 30, 2019
    integer, intent(in)               ::  qcol, zcol
    real(kind=dp), intent(inout)      ::  A(:,:), B(:,:)
    complex(kind=dp), intent(in)      ::  mu
    logical, intent(in)               ::  compQ, compZ, compAB
    real(kind=dp), intent(inout)      ::  Q(:,:), Z(:,:)
    type(tAp), pointer, intent(in)    ::  apC, apT

    real(kind=dp)                     :: c1, s1, c2, s2, c3, s3, r, l1, l2, &
                                         RS(3)
    complex(kind=dp)                  :: V(3), V2(3), M(3,2), a1, a2, &
                                         b1, b2, WORK(6)
    integer,pointer                   :: cstrt, cstp, tstrt, tstp
    integer                           :: INFO, LDQ
    logical                           :: isreal
    real(kind=dp), external           :: DZNRM2
    external                          :: ZGEMV, ZGELS

    call d_getLeadingDim(LDQ,Q)
    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    if (A(cstrt+3,cstrt+1) .gt. dzero) then
      call d_eigenvalues2x2(A,B,cstrt+2,cstrt+1,l1,l2,isreal)
      if (isreal) then
        call d_make_hess(l1,cstrt+2,cstrt+1,A,B,compAB,apC,apT,Q,compQ,qcol+1,&
                Z,compZ,zcol)
        a1 = cmplx(A(cstrt+2,cstrt+1),dzero,kind=dp)
        a2 = cmplx(A(cstrt+3,cstrt+2),dzero,kind=dp)
        b1 = cmplx(B(cstrt+2,cstrt+1),dzero,kind=dp)
        b2 = cmplx(B(cstrt+3,cstrt+2),dzero,kind=dp)
      else
        a1 = cmplx(l1,l2,kind=dp)
        a2 = cmplx(l1,-l2,kind=dp)
        b1 = cone
        b2 = cone
      end if
    else
      a1 = cmplx(A(cstrt+2,cstrt+1),dzero,kind=dp)
      a2 = cmplx(A(cstrt+3,cstrt+2),dzero,kind=dp)
      b1 = cmplx(B(cstrt+2,cstrt+1),dzero,kind=dp)
      b2 = cmplx(B(cstrt+3,cstrt+2),dzero,kind=dp)
      isreal = .true.
    end if

    ! Compute the vector
    V = czero
    V(1) = cone

    ! First pole
    M = b1 * A(cstrt+1:cstrt+3,cstrt+1:cstrt+2) - &
        a1 * B(cstrt+1:cstrt+3,cstrt+1:cstrt+2)
    call ZGELS('N',3,2,1,M(1,1),3,V,3,WORK,6,INFO)
    if (INFO .ne. 0) then
      write(*,*) ' '//achar(27)//'[93m warning '//achar(27)//&
      '[0m solving first LS system for first double pole failed.'
      write(*,*) 'Matrix: ', M
      stop
    end if
    M = A(cstrt+1:cstrt+3,cstrt+1:cstrt+2) - &
        mu * B(cstrt+1:cstrt+3,cstrt+1:cstrt+2)
    call ZGEMV('N',3,2,done,M,3,V,1,czero,V2,1)
    s1 = DZNRM2(3,V2,1)
    V = V2 / s1
    ! Second pole
    M = b2 * A(cstrt+1:cstrt+3,cstrt+1:cstrt+2) - &
        a2 * B(cstrt+1:cstrt+3,cstrt+1:cstrt+2)
    call ZGELS('N',3,2,1,M(1,1),3,V,3,WORK,6,INFO)
    if (INFO .ne. 0) then
      write(*,*) ' '//achar(27)//'[93m warning '//achar(27)//&
      '[0m solving second system for first double pole failed.'
      write(*,*) 'Matrix: ', M
      stop
    end if
    M = A(cstrt+1:cstrt+3,cstrt+1:cstrt+2) - &
        conjg(mu) * B(cstrt+1:cstrt+3,cstrt+1:cstrt+2)
    call ZGEMV('N',3,2,done,M,3,V,1,czero,V2,1)
    s1 = DZNRM2(3,V2,1)
    V = V2 / s1

    ! Compute the transformation
    call d_compute_ct(real(v(2)),real(v(3)),c1,s1,r)
    call d_compute_ct(real(v(1)),r,c2,s2,l1)

    ! Make B block upper triangular
    RS = B(cstrt+1:cstrt+3,cstrt+1)
    l1 = c1 * RS(2) + s1 * RS(3)
    RS(3) = -s1 * RS(2) + c1 * RS(3)
    RS(2) = -s2 * RS(1) + c2 * l1
    call d_compute_ct(RS(2),RS(3),c3,s3,r)

    ! Apply the transformation
    if (compAB) then
      call d_apply_ct_l(A(cstrt+2,cstrt+1:tstp),A(cstrt+3,cstrt+1:tstp),c1,s1)
      call d_apply_ct_l(A(cstrt+1,cstrt+1:tstp),A(cstrt+2,cstrt+1:tstp),c2,s2)
      call d_apply_ct_l(A(cstrt+2,cstrt+1:tstp),A(cstrt+3,cstrt+1:tstp),c3,s3)
      call d_apply_ct_l(B(cstrt+2,cstrt+1:tstp),B(cstrt+3,cstrt+1:tstp),c1,s1)
      call d_apply_ct_l(B(cstrt+1,cstrt+1:tstp),B(cstrt+2,cstrt+1:tstp),c2,s2)
      call d_apply_ct_l(B(cstrt+2,cstrt+1:tstp),B(cstrt+3,cstrt+1:tstp),c3,s3)
    else
      call d_apply_ct_l(A(cstrt+2,cstrt+1:cstp),A(cstrt+3,cstrt+1:cstp),c1,s1)
      call d_apply_ct_l(A(cstrt+1,cstrt+1:cstp),A(cstrt+2,cstrt+1:cstp),c2,s2)
      call d_apply_ct_l(A(cstrt+2,cstrt+1:cstp),A(cstrt+3,cstrt+1:cstp),c3,s3)
      call d_apply_ct_l(B(cstrt+2,cstrt+1:cstp),B(cstrt+3,cstrt+1:cstp),c1,s1)
      call d_apply_ct_l(B(cstrt+1,cstrt+1:cstp),B(cstrt+2,cstrt+1:cstp),c2,s2)
      call d_apply_ct_l(B(cstrt+2,cstrt+1:cstp),B(cstrt+3,cstrt+1:cstp),c3,s3)
    end if
    B(cstrt+3,cstrt+1) = dzero

    if (compQ) then
      call d_apply_ct_r(Q(1:LDQ,qcol+1),Q(1:LDQ,qcol+2),c1,-s1)
      call d_apply_ct_r(Q(1:LDQ,qcol),Q(1:LDQ,qcol+1),c2,-s2)
      call d_apply_ct_r(Q(1:LDQ,qcol+1),Q(1:LDQ,qcol+2),c3,-s3)
    end if
  end subroutine

  subroutine d_first_double_to_inf(A, B, compAB, apC, apT, Q, compQ, qcol)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Shifts the first pole at the start of the current active part to infinity.
  ! This first pole is assumed to be a double pole.
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! A       double array [INOUT]
  !           Upper block-Hessenberg matrix A
  ! B       double array [INOUT]
  !           Upper block-Hessenberg matrix B
  ! compAB  boolean [IN]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the current active part
  ! apC     type(tAp) [IN]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Q       complex double array [INOUT]
  !           Unitary equivalence matrix Q
  ! compQ   boolean [IN]
  !           If true, the left Schur vectors are updated
  ! qcol    integer [IN]
  !           Start index of the columns of Q that are updated:
  !              qcol, qcol+1, qcol+2
  !___________________________________________________________________________
  ! last edit: September 13, 2018
    integer, intent(in)               ::  qcol
    real(kind=dp), intent(inout)      ::  A(:,:), B(:,:)
    logical, intent(in)               ::  compQ, compAB
    real(kind=dp), intent(inout)      ::  Q(:,:)
    type(tAp), pointer, intent(in)    ::  apC, apT

    real(kind=dp)                     :: c1, s1, c2, s2, r
    integer,pointer                   :: cstrt, cstp, tstrt, tstp
    integer                           :: LDQ

    call d_getLeadingDim(LDQ,Q)
    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    call d_compute_ct(B(cstrt+1,cstrt+1),B(cstrt+2,cstrt+1),c1,s1,r)

    if (compAB) then
      call d_apply_ct_l(A(cstrt+1,cstrt+1:tstp),A(cstrt+2,cstrt+1:tstp),c1,s1)
      call d_apply_ct_l(B(cstrt+1,cstrt+1:tstp),B(cstrt+2,cstrt+1:tstp),c1,s1)
    else
      call d_apply_ct_l(A(cstrt+1,cstrt+1:cstp),A(cstrt+2,cstrt+1:cstp),c1,s1)
      call d_apply_ct_l(B(cstrt+1,cstrt+1:cstp),B(cstrt+2,cstrt+1:cstp),c1,s1)
    end if
    B(cstrt+2,cstrt+1) = dzero

    call d_compute_ct(A(cstrt+2,cstrt+1),A(cstrt+3,cstrt+1),c2,s2,r)

    if (compAB) then
      call d_apply_ct_l(A(cstrt+2,cstrt+1:tstp),A(cstrt+3,cstrt+1:tstp),c2,s2)
      call d_apply_ct_l(B(cstrt+2,cstrt+2:tstp),B(cstrt+3,cstrt+2:tstp),c2,s2)
    else
      call d_apply_ct_l(A(cstrt+2,cstrt+1:cstp),A(cstrt+3,cstrt+1:cstp),c2,s2)
      call d_apply_ct_l(B(cstrt+2,cstrt+2:cstp),B(cstrt+3,cstrt+2:cstp),c2,s2)
    end if
    A(cstrt+3,cstrt+1) = dzero

    if (compQ) then
      call d_apply_ct_r(Q(1:LDQ,qcol),Q(1:LDQ,qcol+1),c1,-s1)
      call d_apply_ct_r(Q(1:LDQ,qcol+1),Q(1:LDQ,qcol+2),c2,-s2)
    end if

  end subroutine

  subroutine d_last_single_pole(alpha, beta, A, B, compAB, apC, apT, &
                                Z, compZ, zcol)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Sets the pole of (A,B) in the last position of apC to
  ! alpha / beta
  ! It is assumed that this last pole is currently a single
  ! pole.
  ! If compAB is true, the complete pencil is updated based on apT,
  ! if not only the active part apC is updated
  ! If compZ is true, the ctransformation is also applied to
  ! the columns of Z specified by zcol
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! alpha   double [IN]
  !           Defines the new last pole: alpha/beta
  ! beta    double [IN]
  !           Defines the new last pole: alpha/beta
  ! A       double array [INOUT]
  !           Upper block-Hessenberg matrix A
  ! B       double array [INOUT]
  !           Upper block-Hessenberg matrix B
  ! compAB  boolean [IN]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the active parts
  ! apC     type(tAp) [INOUT]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Z       double array [INOUT]
  !           Unitary equivalence matrix Z
  ! compZ   boolean [IN]
  !           If true, the right Schur vectors are updated
  ! zcol    integer [IN]
  !           Start index of the columns of Z that are updated:
  !              zcol, zcol+1
  !___________________________________________________________________________
  ! last edit: September 5, 2018
    integer, intent(in)               ::  zcol
    real(kind=dp), intent(inout)      ::  A(:,:), B(:,:)
    real(kind=dp), intent(in)         ::  alpha, beta
    logical, intent(in)               ::  compAB, compZ
    real(kind=dp), intent(inout)      ::  Z(:,:)
    type(tAp), pointer, intent(in)    ::  apC
    type(tAp), pointer, intent(in)    ::  apT

    real(kind=dp)                     ::  v(2), c, s, r
    integer,pointer                   ::  cstrt, cstp, tstrt, tstp
    real(kind=dp), external           ::  ddot

    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    ! Compute and normalize the vector of interest
    v = A(cstp,cstp-1:cstp) * beta - B(cstp,cstp-1:cstp) * alpha
    s = ddot(2,v,1,v,1)
    v = v / sqrt(abs(s))

    if (abs(v(2)) > mp) then
      call d_compute_ct(v(2),v(1),c,s,r)
      if (compAB) then
          call d_apply_ct_r(A(tstrt+1:cstp,cstp-1),A(tstrt+1:cstp,cstp),c,s)
          call d_apply_ct_r(B(tstrt+1:cstp,cstp-1),B(tstrt+1:cstp,cstp),c,s)
      else
          call d_apply_ct_r(A(cstrt+1:cstp,cstp-1),A(cstrt+1:cstp,cstp),c,s)
          call d_apply_ct_r(B(cstrt+1:cstp,cstp-1),B(cstrt+1:cstp,cstp),c,s)
      endif

      if (compZ) then
        call d_apply_ct_r(Z(:,zcol),Z(:,zcol+1),c,s)
      end if
    end if
  end subroutine

  subroutine d_last_double_pole(mu, A, B, compAB, apC, apT, Q, compQ, qcol, &
               Z, compZ, zcol)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Sets the poles of (A,B) in the last and second-to-last position
  ! of apC to mu and conjg(mu).
  ! It is assumed that these poles are currently either consecutive
  ! single poles or a double pole.
  ! If compAB is true, the complete pencil is updated based on apT,
  ! if not only the active part apC is updated
  ! If compZ is true, the ctransformation is also applied to
  ! the columns of Z specified by zcol
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! mu      complex double [IN]
  !           Defines the new last poles: mu and conjg(mu)
  ! A       double array [INOUT]
  !           Upper block-Hessenberg matrix A
  ! B       double array [INOUT]
  !           Upper block-Hessenberg matrix B
  ! compAB  boolean [IN]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the active parts
  ! apC     type(tAp) [INOUT]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Z       double array [INOUT]
  !           Unitary equivalence matrix Z
  ! compZ   boolean [IN]
  !           If true, the right Schur vectors are updated
  ! zcol    integer [IN]
  !           Start index of the columns of Z that are updated:
  !              zcol, zcol+1
  !___________________________________________________________________________
  ! last edit: January 30, 2019
    integer, intent(in)               ::  zcol, qcol
    real(kind=dp), intent(inout)      ::  A(:,:), B(:,:)
    complex(kind=dp), intent(in)      ::  mu
    logical, intent(in)               ::  compAB, compQ, compZ
    real(kind=dp), intent(inout)      ::  Z(:,:), Q(:,:)
    type(tAp), pointer, intent(in)    ::  apC
    type(tAp), pointer, intent(in)    ::  apT

    real(kind=dp)                     :: c1, s1, c2, s2, c3, s3, r, l1, l2, &
                                         RS(3)
    complex(kind=dp)                  :: V(3), V2(3), M(2,3), a1, a2, &
                                         b1, b2, WORK(6)
    integer,pointer                   :: cstrt, cstp, tstrt, tstp
    integer                           :: INFO
    logical                           :: isreal
    real(kind=dp), external           :: DZNRM2
    external                          :: ZGEMV, ZGELS

    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    if (abs(A(cstp,cstp-2)) .gt. dzero) then
      call d_eigenvalues2x2(A,B,cstp-1,cstp-2,l1,l2,isreal)
      if (isreal) then
        call d_make_hess(l1,cstp-1,cstp-2,A,B,compAB,apC,apT,Q,compQ,qcol,&
               Z,compZ,zcol)
        a1 = cmplx(A(cstp,cstp-1),dzero,kind=dp)
        a2 = cmplx(A(cstp-1,cstp-2),dzero,kind=dp)
        b1 = cmplx(B(cstp,cstp-1),dzero,kind=dp)
        b2 = cmplx(B(cstp-1,cstp-2),dzero,kind=dp)
      else
        a1 = cmplx(l1,l2,kind=dp)
        a2 = cmplx(l1,-l2,kind=dp)
        b1 = cone
        b2 = cone
      end if
    else
      a1 = cmplx(A(cstp,cstp-1),dzero,kind=dp)
      a2 = cmplx(A(cstp-1,cstp-2),dzero,kind=dp)
      b1 = cmplx(B(cstp,cstp-1),dzero,kind=dp)
      b2 = cmplx(B(cstp-1,cstp-2),dzero,kind=dp)
      isreal = .true.
    end if

    ! Compute the vector
    V = czero
    V(3) = cone

    ! First pole
    M = b1 * A(cstp-1:cstp,cstp-2:cstp) - &
        a1 * B(cstp-1:cstp,cstp-2:cstp)
    call ZGELS('C',2,3,1,M(1,1),2,V,3,WORK,6,INFO)
    if (INFO .ne. 0) then
      write(*,*) ' '//achar(27)//'[93m warning '//achar(27)//&
      '[0m solving LS system for last double pole failed.'
      write(*,*) 'Matrix: ', M
      stop
    end if
    M = A(cstp-1:cstp,cstp-2:cstp) - &
        mu * B(cstp-1:cstp,cstp-2:cstp)
    call ZGEMV('C',2,3,done,M(1,1),2,V(1),1,czero,V2(1),1)
    s1 = DZNRM2(3,V2,1)
    V = V2 / s1
    ! Second pole
    M = b2 * A(cstp-1:cstp,cstp-2:cstp) - &
        a2 * B(cstp-1:cstp,cstp-2:cstp)
    call ZGELS('C',2,3,1,M(1,1),2,V,3,WORK,6,INFO)
    if (INFO .ne. 0) then
      write(*,*) ' '//achar(27)//'[93m warning '//achar(27)//&
      '[0m solving LS system for last double pole failed.'
      write(*,*) 'Matrix: ', M
      stop
    end if
    M = A(cstp-1:cstp,cstp-2:cstp) - &
        conjg(mu) * B(cstp-1:cstp,cstp-2:cstp)
    call ZGEMV('C',2,3,done,M(1,1),2,V(1),1,czero,V2(1),1)
    s1 = DZNRM2(3,V2,1)
    V = V2 / s1
    ! Compute the transformation
    call d_compute_ct(real(V(2)),real(V(1)),c1,s1,r)
    call d_compute_ct(real(V(3)),r,c2,s2,l1)

    ! Make B block upper triangular
    RS = B(cstp,cstp-2:cstp)
    l1 = s1 * RS(1) + c1 * RS(2)
    RS(1) = c1 * RS(1) - s1 * RS(2)
    RS(2) = c2 * l1 - s2 * RS(3)
    call d_compute_ct(RS(2),RS(1),c3,s3,r)

    ! Apply the transformation
    if (compAB) then
      call d_apply_ct_r(A(tstrt+1:cstp,cstp-2),A(tstrt+1:cstp,cstp-1),c1,s1)
      call d_apply_ct_r(A(tstrt+1:cstp,cstp-1),A(tstrt+1:cstp,cstp),c2,s2)
      call d_apply_ct_r(A(tstrt+1:cstp,cstp-2),A(tstrt+1:cstp,cstp-1),c3,s3)
      call d_apply_ct_r(B(tstrt+1:cstp,cstp-2),B(tstrt+1:cstp,cstp-1),c1,s1)
      call d_apply_ct_r(B(tstrt+1:cstp,cstp-1),B(tstrt+1:cstp,cstp),c2,s2)
      call d_apply_ct_r(B(tstrt+1:cstp,cstp-2),B(tstrt+1:cstp,cstp-1),c3,s3)
    else
      call d_apply_ct_r(A(cstrt+1:cstp,cstp-2),A(cstrt+1:cstp,cstp-1),c1,s1)
      call d_apply_ct_r(A(cstrt+1:cstp,cstp-1),A(cstrt+1:cstp,cstp),c2,s2)
      call d_apply_ct_r(A(cstrt+1:cstp,cstp-2),A(cstrt+1:cstp,cstp-1),c3,s3)
      call d_apply_ct_r(B(cstrt+1:cstp,cstp-2),B(cstrt+1:cstp,cstp-1),c1,s1)
      call d_apply_ct_r(B(cstrt+1:cstp,cstp-1),B(cstrt+1:cstp,cstp),c2,s2)
      call d_apply_ct_r(B(cstrt+1:cstp,cstp-2),B(cstrt+1:cstp,cstp-1),c3,s3)
    end if
    B(cstp,cstp-2) = dzero

    if (compZ) then
      call d_apply_ct_r(Z(:,zcol),Z(:,zcol+1),c1,s1)
      call d_apply_ct_r(Z(:,zcol+1),Z(:,zcol+2),c2,s2)
      call d_apply_ct_r(Z(:,zcol),Z(:,zcol+1),c3,s3)
    end if

  end subroutine

  subroutine d_last_double_to_inf( A, B, compAB, apC, apT, Z, compZ, zcol)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Shifts the last pole at the end of the current active part to infinity.
  ! This last pole is assumed to be a double pole.
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! A       double array [INOUT]
  !           Upper block-Hessenberg matrix A
  ! B       double array [INOUT]
  !           Upper block-Hessenberg matrix B
  ! compAB  boolean [IN]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the current active part
  ! apC     type(tAp) [IN]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Z       complex double array [INOUT]
  !           Unitary equivalence matrix Z
  ! compZ   boolean [IN]
  !           If true, the right Schur vectors are updated
  ! zqcol    integer [IN]
  !           Start index of the columns of Z that are updated:
  !              zcol, zcol+1, zcol+2
  !___________________________________________________________________________
  ! last edit: September 13, 2018
    integer, intent(in)               ::  zcol
    real(kind=dp), intent(inout)      ::  A(:,:), B(:,:)
    logical, intent(in)               ::  compZ, compAB
    real(kind=dp), intent(inout)      ::  Z(:,:)
    type(tAp), pointer, intent(in)    ::  apC, apT

    real(kind=dp)                     :: c1, s1, c2, s2, r
    integer,pointer                   :: cstrt, cstp, tstrt, tstp
    integer                           :: LDZ

    call d_getLeadingDim(LDZ,Z)
    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    call d_compute_ct(B(cstp,cstp),B(cstp,cstp-1),c1,s1,r)

    if (compAB) then
      call d_apply_ct_r(A(tstrt+1:cstp,cstp-1),A(tstrt+1:cstp,cstp),c1,s1)
      call d_apply_ct_r(B(tstrt+1:cstp,cstp-1),B(tstrt+1:cstp,cstp),c1,s1)
    else
      call d_apply_ct_r(A(cstrt+1:cstp,cstp-1),A(cstrt+1:cstp,cstp),c1,s1)
      call d_apply_ct_r(B(cstrt+1:cstp,cstp-1),B(cstrt+1:cstp,cstp),c1,s1)
    end if
    B(cstp,cstp-1) = dzero

    call d_compute_ct(A(cstp,cstp-1),A(cstp,cstp-2),c2,s2,r)

    if (compAB) then
      call d_apply_ct_r(A(tstrt+1:cstp,cstp-2),A(tstrt+1:cstp,cstp-1),c2,s2)
      call d_apply_ct_r(B(tstrt+1:cstp,cstp-2),B(tstrt+1:cstp,cstp-1),c2,s2)
    else
      call d_apply_ct_r(A(cstrt+1:cstp,cstp-2),A(cstrt+1:cstp,cstp-1),c2,s2)
      call d_apply_ct_r(B(cstrt+1:cstp,cstp-2),B(cstrt+1:cstp,cstp-1),c2,s2)
    end if
    A(cstp,cstp-2) = dzero

    if (compZ) then
      call d_apply_ct_r(Z(1:LDZ,zcol+1),Z(1:LDZ,zcol+2),c1,s1)
      call d_apply_ct_r(Z(1:LDZ,zcol),Z(1:LDZ,zcol+1),c2,s2)
    end if
  end subroutine

  subroutine d_first_m_poles(m,alpha,beta,k,mur,mui,l,A,B,compAB,apC, apT,&
                Q, compQ, qcol, Z, compZ, zcol )
  ! DESCRIPTION
  !___________________________________________________________________________
  !
  ! Sets the first k+2*l(+1) poles of (A,B) starting at the first position of
  ! the current active part apC to the poles as specified by the arrays:
  !                    k: alpha./beta, and, 2*l: mur +-1i* mui
  ! If compAB is true, the complete pencil is updated based on apT, if not,
  ! only the active part apC of the pencil is updated
  ! If compQ is true, the matrix Q is updated accordingly. If compZ is true,
  ! the matrix Z is updated accordingly
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! m       integer [OUT]
  !           Total number of shifts that was introduced: m = k + 2*l (+1)
  !           Can be 1 larger than requested IF it did not match
  ! alpha   double array [IN]
  !           Defines k real shifts: alpha/beta
  !           Array with at least k elements
  ! beta    double array [IN]
  !           Defines k real shifts: alpha/beta
  !           Array with at least k elements
  ! k       integer [IN]
  !           Number of real shifts
  ! mur     double array [IN]
  !           Real parts of l pairs of C.C. shifts: mur +- 1i * muc
  !           Array with at least l elements
  ! mui     double array [IN]
  !           Imaginary parts of l pairs of C.C. shifts: mur +- 1i * muc
  !           Array with at least l elements
  ! l       integer [IN]
  !           Number of C.C. pairs to be introduced
  !           (total of 2*l complex shifts)
  ! A       double array [INOUT]
  !           Upper block-Hessenberg matrix A
  ! B       double array [INOUT]
  !           Upper block-Hessenberg matrix B
  ! compAB  boolean [IN]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the active parts
  ! apC     type(tAp) [IN]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Q       double array [INOUT]
  !           Orthonormal equivalence matrix Q
  ! compQ   boolean [IN]
  !           If true, the left Schur vectors are updated
  ! qcol    integer [IN]
  !           Start index of the columns of Q that are updated:
  !              qcol, qcol+m+1
  ! Z       double array [INOUT]
  !           Orthonormal equivalence matrix Z
  ! compZ   boolean [IN]
  !           If true, the right Schur vectors are updated
  ! zcol    integer [IN]
  !           Start index of the columns of Z that are updated:
  !              zcol, zcol+m
  !___________________________________________________________________________
  ! last edit: September 21, 2018
    real(kind=dp), intent(inout)      :: A(:,:), B(:,:), Q(:,:), Z(:,:)
    real(kind=dp), intent(in)         :: alpha(:), beta(:),mur(:),mui(:)
    logical, intent(in)               :: compAB, compQ, compZ
    type(tAp), pointer, intent(in)    :: apC, apT
    integer, intent(in)               :: qcol, zcol
    integer, intent(inout)            :: m, k, l

    integer                           :: i, j, LDAB, LDQ, LDQM, LDZ, &
                                         LDZM, LDC, LDR
    integer,pointer                   :: cstrt, cstp, tstrt, tstp
    type(tAp), pointer                :: apCI, apTI

    external DGEMM

    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    m = k + 2*l
    if (abs(A(cstrt+m+2,cstrt+m)) .gt. dzero) then
      m = m + 1
    end if

    call d_getLeadingDim(LDAB,A)
    call d_getLeadingDim(LDQ,Q)
    call d_getLeadingDim(LDQM,QM)
    call d_getLeadingDim(LDZ,Z)
    call d_getLeadingDim(LDZM,ZM)
    call d_getLeadingDim(LDC,Cu)
    call d_getLeadingDim(LDR,Ru)

    ! Initialize internal variables
    call tApInit(apCI,cstrt, cstrt+m)
    call tApInit(apTI,cstrt, cstrt+m)

    QM = dzero
    do i=1, m+1
        QM(i,i) = done
    end do

    ZM = dzero
    do i=1, m
        ZM(i,i) = done
    end do

    do while (k+l .gt. 0)
      ! Check what the current first pole is
      if (abs(A(cstrt+3,cstrt+1)) .gt. dzero) then
        ! Current first is c.c.
        if (l .gt. 0) then
          ! We can introduce c.c
          call d_first_double_pole(cmplx(mur(l),mui(l),kind=dp), A, B, .true., &
                 apCI, apTI, QM, .true., 1, ZM, .true., 1)
          l = l - 1
          j = 1
          do while (j .le. k+2*l)
            if (abs(A(cstrt+j+4,cstrt+j+2)) .gt. dzero) then
              call d_swap22(cstrt+j+1, cstrt+j, A, B, .true., apCI, apTI, &
                     QM, .true., j+1, ZM, .true., j)
              j = j + 2
            else
              call d_swap21(cstrt+j+1, cstrt+j, A, B, .true., apCI, apTI, &
                     QM, .true., j+1, ZM, .true., j)
              j = j + 1
            end if
          end do
        else
          ! Shift to Inf
          call d_first_double_to_inf(A, B, .true., apCI, apTI, QM, .true., 1)
          call d_first_single_pole(alpha(k), beta(k), A, B, .true., apCI, apTI,&
                              QM, .true., 1)
          call d_swap11(cstrt+2, cstrt+1, A, B, .true., apCI, apTI, &
                   QM, .true., 2, ZM, .true., 1)
          if (k .gt. 1) then
            ! introduce two different reals
            call d_first_single_pole(alpha(k-1), beta(k-1), A, B, .true., &
                   apCI, apTI, QM, .true., 1)
            k = k - 2
          else
            ! introduce twice the same real (should be the last)
            call d_first_single_pole(alpha(k), beta(k), A, B, .true., &
                    apCI, apTI, QM, .true., 1)
            k = k - 1
          end if
          j = 1
          do while (j .le. k+2*l)
            if (abs(A(cstrt+j+4,cstrt+j+2)) .gt. dzero) then
              call d_swap12(cstrt+j+2, cstrt+j+1, A, B, .true., apCI, apTI, &
                     QM, .true., j+2, ZM, .true., j+1)
              call d_swap12(cstrt+j+1, cstrt+j, A, B, .true., apCI, apTI, &
                     QM, .true., j+1, ZM, .true., j)
              j = j + 2
            else
              call d_swap11(cstrt+j+2, cstrt+j+1, A, B, .true., apCI, apTI, &
                     QM, .true., j+2, ZM, .true., j+1)
              call d_swap11(cstrt+j+1, cstrt+j, A, B, .true., apCI, apTI, &
                     QM, .true., j+1, ZM, .true., j)
              j = j + 1
            end if
          end do
        end if
      else
        ! Current first is real
        if (k .gt. 0) then
          ! Set real
          call d_first_single_pole(alpha(k), beta(k), A, B, .true., apCI, apTI,&
                                   QM, .true., 1)
          ! Swap to the back
          j = 1
          do while (j .lt. k+2*l)
            if (abs(A(cstrt+j+3,cstrt+j+1)) .gt. dzero) then
              call d_swap12(cstrt+j+1, cstrt+j, A, B, .true., apCI, apTI, &
                     QM, .true., j+1, ZM, .true., j)
              j = j + 2
            else
              call d_swap11(cstrt+j+1, cstrt+j, A, B, .true., apCI, apTI, &
                     QM, .true., j+1, ZM, .true., j)
              j = j + 1
            end if
          end do
          k = k - 1 !Update counter
        else
          ! l is greater than 0 (otherwise this is never reached)
          if (abs(A(cstrt+4,cstrt+2)) .gt. dzero) then
            call d_swap12(cstrt+2, cstrt+1, A, B, .true., apCI, apTI, &
                   QM, .true.,2, ZM, .true., 1)
          end if
          ! Set cc
          call d_first_double_pole(cmplx(mur(l),mui(l),kind=dp),A, B, .true., &
                 apCI,apTI,QM, .true. ,1,ZM,.true.,1)
          j = 1

          do while (j .lt. 2*l-1)
            if (abs(A(cstrt+j+4,cstrt+j+2)) .gt. dzero) then
              call d_swap22(cstrt+j+1, cstrt+j, A, B, .true., apCI, apTI, &
                     QM, .true., j+1, ZM, .true., j)
              j = j + 2
            else
              call d_swap21(cstrt+j+1, cstrt+j, A, B, .true., apCI, apTI, &
                     QM, .true., j+1, ZM, .true., j)
              j = j + 1
            end if
          end do
          l = l - 1 !Update counter
        end if
      end if
    end do

    ! Update the remainder of the pencil
    if (compAB) then
      ! A row update
      call DGEMM('T','N',m+1,tstp-cstrt-m,m+1,done,QM(1,1),LDQM,&
                 A(cstrt+1,cstrt+m+1),LDAB,dzero,Ru(1,1),LDR)
      A(cstrt+1:cstrt+m+1,cstrt+m+1:tstp) = Ru(1:m+1,1:tstp-cstrt-m)
      ! B row update
      call DGEMM('T','N',m+1,tstp-cstrt-m,m+1,done,QM(1,1),LDQM,&
                 B(cstrt+1,cstrt+m+1),LDAB,dzero,Ru(1,1),LDR)
      B(cstrt+1:cstrt+m+1,cstrt+m+1:tstp) = Ru(1:m+1,1:tstp-cstrt-m)
      if (cstrt .gt. 0) then
        ! A column update
        call DGEMM('N','N',cstrt-tstrt,m,m,done,A(tstrt+1,cstrt+1),LDAB,&
                   ZM(1,1),LDZM,dzero,Cu(1,1),LDC)
        A(tstrt+1:cstrt,cstrt+1:cstrt+m) = Cu(1:cstrt-tstrt,1:m)
        ! B column update
        call DGEMM('N','N',cstrt-tstrt,m,m,done,B(tstrt+1,cstrt+1),LDAB,&
                   ZM(1,1),LDZM,dzero,Cu(1,1),LDC)
        B(tstrt+1:cstrt,cstrt+1:cstrt+m) = Cu(1:cstrt-tstrt,1:m)
      end if
    else
      ! A row update
      call DGEMM('N','N',m+1,cstp-cstrt-m,m+1,done,QM(1,1),LDQM,&
                 A(cstrt+1,cstrt+m+1),LDAB,dzero,Ru(1,1),LDR)
      A(cstrt+1:cstrt+m+1,cstrt+m+1:cstp) = Ru(1:m+1,1:cstp-cstrt-m)
      ! B row update
      call DGEMM('N','N',m+1,cstp-cstrt-m,m+1,done,QM(1,1),LDQM,&
                 B(cstrt+1,cstrt+m+1),LDAB,dzero,Ru(1,1),LDR)
      B(cstrt+1:cstrt+m+1,cstrt+m+1:cstp) = Ru(1:m+1,1:cstp-cstrt-m)
    end if

    if (compQ) then
      call DGEMM('N','N',LDQ,m+1,m+1,done,Q(1,qcol),LDQ,&
                 QM(1,1),LDQM,dzero,Cu,LDC)
      Q(1:LDQ,qcol:qcol+m) = Cu(1:LDQ,1:m+1)
    end if

    if (compZ) then
      call DGEMM('N','N',LDZ,m,m,done,Z(1,zcol),LDZ,ZM(1,1),LDZM,dzero,Cu,LDC)
      Z(1:LDZ,zcol:zcol+m-1) = Cu(1:LDZ,1:m)
    end if

    ! Free everything
    call tApFree(apCI)
    call tApFree(apTI)
  end subroutine

  subroutine d_last_m_poles(m,bf,alpha,beta,k,mur,mui,l,A,B,compAB,apC, apT, &
               Q, compQ, qcol, Z, compZ, zcol )
  ! DESCRIPTION
  !___________________________________________________________________________
  !
  ! Sets the last m=k+2*l poles of (A,B) starting at the last position of
  ! the current active part apC to the poles as specified by the arrays:
  !                    k: alpha./beta, and, 2*l: mur +-1i* mui
  ! If compAB is true, the complete pencil is updated, if not, only the active
  ! part of the pencil is updated
  ! If compQ is true, the matrix Q is updated accordingly. If compZ is true,
  ! the matrix Z is updated accordingly
  ! Deflations are monitored during the pole introduction. Active part can
  ! shift.
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! m       integer [OUT]
  !           Total number of shifts that was introduced: m = k + 2*l (+1)
  !           Can be 1 larger than requested IF it did not match
  ! bf      integer [IN]
  !           Buffer size to compensate for deflations that might occur during
  !           pole introductions. QM, ZM should be of dimension m+bf+1
  ! alpha   double array [IN]
  !           Defines k real shifts: alpha/beta
  !           Array with at least k elements
  ! beta    double array [IN]
  !           Defines k real shifts: alpha/beta
  !           Array with at least k elements
  ! k       integer [IN]
  !           Number of real shifts
  ! mur     double array [IN]
  !           Real parts of l pairs of C.C. shifts: mur +- 1i * muc
  !           Array with at least l elements
  ! mui     double array [IN]
  !           Imaginary parts of l pairs of C.C. shifts: mur +- 1i * muc
  !           Array with at least l elements
  ! l       integer [IN]
  !           Number of C.C. pairs to be introduced
  !           (total of 2*l complex shifts)
  ! A       double array [INOUT]
  !           Upper block-Hessenberg matrix A
  ! B       double array [INOUT]
  !           Upper block-Hessenberg matrix B
  ! compAB  boolean [IN]
  !           If true, the equivalences are applied to (A,B). If not,
  !           then only to the active parts
  ! apC     type(tAp) [IN]
  !           Current active part
  ! apT     type(tAp) [IN]
  !           Total part of the pencil the method is acting on
  !           (used when compAB is true)
  ! Q       double array [INOUT]
  !           Orthonormal equivalence matrix Q
  ! compQ   boolean [IN]
  !           If true, the left Schur vectors are updated
  ! qcol    integer [IN] ! TODO qcol should point at the last one
  !           Start index of the columns of Q that are updated:
  !              qcol, qcol+m+bf-1
  ! Z       double array [INOUT]
  !           Orthonormal equivalence matrix Z
  ! compZ   boolean [IN]
  !           If true, the right Schur vectors are updated
  ! zcol    integer [IN]
  !           Start index of the columns of Z that are updated:
  !              zcol, zcol+m+bf
  !___________________________________________________________________________
  ! last edit: February 20, 2019
    real(kind=dp), intent(inout)      :: A(:,:), B(:,:), Q(:,:), Z(:,:)
    real(kind=dp), intent(in)         :: alpha(:), beta(:),mur(:),mui(:)
    logical, intent(in)               :: compAB, compQ, compZ
    type(tAp), pointer, intent(in)    :: apC, apT
    integer, intent(in)               :: qcol, zcol
    integer, intent(inout)            :: m, k, l, bf

    logical                           :: defl, defli
    integer                           :: i, LDAB, LDQ, LDQM, LDZ, &
                                         LDZM, LDC, LDR, mi, &
                                         cstpe, cendm, fendm, &
                                         ndef, nbuf, nuc, nc, sz, cdif
    integer,pointer                   :: cstrt, cstp, tstrt, tstp, &
                                         cstrti, cstpi
    type(tAp), pointer                :: apCI, apTI

    external DGEMM

    call tApGet(apC,cstrt,cstp)
    call tApGet(apT,tstrt,tstp)

    call d_getLeadingDim(LDAB,A)
    call d_getLeadingDim(LDQ,Q)
    call d_getLeadingDim(LDQM,QM)
    call d_getLeadingDim(LDZ,Z)
    call d_getLeadingDim(LDZM,ZM)
    call d_getLeadingDim(LDC,Cu)
    call d_getLeadingDim(LDR,Ru)

    m = k + 2*l
    ! Initialize internal variables
    call tApInit(apCI,cstp-m-bf, cstp)
    call tApInit(apTI,cstp-m-bf, cstp)
    call tApGet(apCI,cstrti,cstpi)
    cstpe = cstpi

    ! Set entire matrices to identity
    QM = dzero
    do i=1, LDQM
        QM(i,i) = done
    end do
    ZM = dzero
    do i=1, LDZM
        ZM(i,i) = done
    end do

    ! Ensure m covers integer number of blocks
    mi = m
    if (abs(A(cstp-m+1,cstp-m-1)) .gt. dzero) then
      m = m + 1
      bf = bf - 1
    end if
    ! Set all counters
    defl = .false.
    ndef = 0
    nbuf = bf
    nc = 0
    nuc = m
    cendm = LDZM ! current end index in QM,ZM corresponding with cstpi
    fendm = LDZM

    ! Phase 1: Introduce all l double poles
    do while (l .gt. 0)
      sz = 2
      call moveLucSzToEnd(A,B,apCI,apTI,sz,cendm,nc,nuc,nbuf)
      if (sz .gt. 0) then
        ! The two last poles are now unchanged
        call d_stop_deflation_double(defli, A, B, .true., &
             apCI, apTI, QM, .true., cendm-1, ZM, .true., cendm-2)
        if (defli) then
          defl = .true.
          cdif = cstpe-cstpi
          ndef = ndef + cdif
          nbuf = nbuf - cdif
          nuc = nuc + cdif
          cendm = cendm - cdif
          cstpe = cstpi
          if (nbuf .lt. 3) exit
          if (cdif .eq. 1) then
            nc = nc + 1
          end if
        else
          nuc = nuc - sz
          nc = nc + sz
          call d_last_double_pole(cmplx(mur(l),mui(l),kind=dp), A, B, &
                 .true., apCI, apTI, QM, .true., cendm-1, ZM, .true., cendm-2)
          l = l - 1
        end if
      else
        ! sz = - 1
        exit
      end if
    ! End of phase 1
    end do

    ! Phase 2: Introduce all k single poles
    do while (k .gt. 0)
      sz = 1
      call moveLucSzToEnd(A,B,apCI,apTI,sz,cendm,nc,nuc,nbuf)
      if (sz .gt. 0) then
        if (sz .eq. 1) then
          call d_stop_deflation_single(defli, A, B, .true., &
                  apCI, apTI, ZM, .true., cendm-1)
          if (defli) then
            defl = .true.
            cdif = cstpe-cstpi
            ndef = ndef + cdif
            nbuf = nbuf - cdif
            nuc = nuc + cdif
            cendm = cendm - cdif
            cstpe = cstpi
            if (nbuf .lt. 2) exit
            if (cdif .eq. 2) then
              nc = nc - 1
            end if
          else
            nuc = nuc - 1
            nc = nc + 1
            call d_last_single_pole(alpha(k), beta(k), A, B, .true., &
                 apCI, apTI, ZM, .true., cendm-1)
            k = k - 1
          end if
        else
          ! sz = 2
          call d_stop_deflation_double(defli, A, B, .true., &
                apCI, apTI, QM, .true., cendm-1, ZM, .true., cendm-2)
          if (defli) then
            defl = .true.
            cdif = cstpe-cstpi
            ndef = ndef + cdif
            nbuf = nbuf - cdif
            nuc = nuc + cdif
            cendm = cendm - cdif
            cstpe = cstpi
            if (nbuf .lt. 2) exit
            if (cdif .eq. 1) then
              nc = nc + 1
            end if
          else
            nuc = nuc - 2
            nc = nc + 2
            ! Can be a double pole
            if (abs(A(cstpi,cstpi-2)) .gt. dzero) then
              call d_last_double_to_inf( A, B, .true., apCI, apTI, &
                   ZM, .true., cendm-2)
            end if
            call d_last_single_pole(alpha(k), beta(k), A, B, .true., &
               apCI, apTI, ZM, .true., cendm-1)
            k = k - 1
            call d_swap11(cstpi-1, cstpi-2, A, B, .true., apCI, apTI, &
               QM, .true., cendm-1, ZM, .true., cendm-2)
            if (k .eq. 0) k = 1
            call d_last_single_pole(alpha(k), beta(k), A, B, .true., &
               apCI, apTI, ZM, .true., cendm-1)
            k = k - 1
          end if
        end if
      else
        ! sz = -1
        exit
      end if
    end do

    ! Update the rest of the pencil and Q,Z matrices via BLAS
    if (compAB) then
      ! A column update
      call DGEMM('N','N',cstp-m-bf-tstrt,m+ndef+1,m+ndef+1,done,A(tstrt+1,cstp-m-ndef),LDAB,&
            ZM(LDZM-m-ndef,LDZM-m-ndef), LDZM, dzero, Cu(1,1), LDC)
      A(tstrt+1:cstp-m-bf,cstp-m-ndef:cstp) = Cu(1:cstp-m-bf-tstrt,1:m+ndef+1)
      ! B column update
      call DGEMM('N','N',cstp-m-bf-tstrt,m+ndef+1,m+ndef+1,done,B(tstrt+1,cstp-m-ndef),LDAB,&
            ZM(LDZM-m-ndef,LDZM-m-ndef), LDZM, dzero, Cu(1,1), LDC)
      B(tstrt+1:cstp-m-bf,cstp-m-ndef:cstp) = Cu(1:cstp-m-bf-tstrt,1:m+ndef+1)
      if (cstp .lt. tstp) then
        ! A row update
        call DGEMM('T','N', m+ndef, tstp-cstp, m+ndef, done, QM(LDQM-m-ndef+1,LDQM-m-ndef+1), LDQM,&
              A(cstp-m-ndef+1,cstp+1), LDAB, dzero, Ru(1,1), LDR)
        A(cstp-m-ndef+1:cstp,cstp+1:tstp) = Ru(1:m+ndef,1:tstp-cstp)
        ! B row update
        call DGEMM('T','N',m+ndef,tstp-cstp,m+ndef,done,QM(LDQM-m-ndef+1,LDQM-m-ndef+1),LDQM,&
              B(cstp-m-ndef+1,cstp+1), LDAB, dzero, Ru(1,1), LDR)
        B(cstp-m-ndef+1:cstp,cstp+1:tstp) = Ru(1:m+ndef,1:tstp-cstp)
      end if
    else
      ! A column update
      call DGEMM('N','N',cstp-m-bf-cstrt,m+ndef+1,m+ndef+1,done,A(cstrt+1,cstp-m-ndef),LDAB,&
            ZM(LDZM-m-ndef,LDZM-m-ndef), LDZM, dzero, Cu(1,1), LDC)
      A(cstrt+1:cstp-m-bf,cstp-m-ndef:cstp) = Cu(1:cstp-m-bf-cstrt,1:m+ndef+1)
      ! B column update
      call DGEMM('N','N',cstp-m-bf-cstrt,m+ndef+1,m+ndef+1,done,B(cstrt+1,cstp-m-ndef),LDAB,&
            ZM(LDZM-m-ndef,LDZM-m-ndef), LDZM, dzero, Cu(1,1), LDC)
      B(cstrt+1:cstp-m-bf,cstp-m-ndef:cstp) = Cu(1:cstp-m-bf-cstrt,1:m+ndef+1)
    end if

    if (compQ) then
      call DGEMM('N','N',LDQ,m+ndef,m+ndef,done,Q(1,qcol-m-ndef+1),LDQ,QM(LDQM-m-ndef+1,LDQM-m-ndef+1),LDQM,dzero,Cu,LDC)
      Q(1:LDQ,qcol-m-ndef+1:qcol) = Cu(1:LDQ,1:m+ndef)
    end if

    if (compZ) then
      call DGEMM('N','N',LDZ,m+ndef+1,m+ndef+1,done,Z(1,zcol-m-ndef),LDZ,ZM(LDZM-m-ndef,LDZM-m-ndef),LDZM,&
                 dzero,Cu,LDC)
      Z(1:LDZ,zcol-m-ndef:zcol) = Cu(1:LDZ,1:m+ndef+1)
    end if

    if (defl) then
      cstp = cstpi
    end if

    ! Free everything
    call tApFree(apCI)
    call tApFree(apTI)

  end subroutine

  recursive subroutine moveLucSzToEnd(A,B,apCI,apTI,sz,cendm,nc,nuc,nbuf)
    ! Move last unchanged pole of the desired size
    ! to the end of the range
    !
    ! (A,B) : pencil
    ! apCI, apTI : active range (contains cstpi)
    ! sz:  specifies if we want a single or double pole
    ! cendm: current end in QM,ZM
    ! nc: number of changed poles
    ! nuc: number of unchanged poles
    ! nbuf: remaining buffer size

    real(kind=dp), intent(inout)    :: A(:,:), B(:,:)
    type(tAp), pointer, intent(in)  :: apCI, apTI
    integer, intent(in)             :: cendm, nc, nuc, nbuf
    integer, intent(inout)          :: sz

    integer :: j, jm ! index in A,B and QM, ZM
    integer :: jmin ! minimal column index in A,B
    integer, pointer :: cstrti, cstpi
    logical :: ds

    call tApGet(apCI,cstrti,cstpi)
    j = cstpi - nc - 1
    jm = cendm - nc - 1
    jmin = cstpi - nc - nuc - 1

    if ((sz .eq. 2) .and. (nuc .gt. 1)) then
      ! Look for 2 consecutive 1x1 or a 2x2 (can be found in last 3 poles)
      j = j - 1
      jm = jm - 1
      if (abs(A(j+2,j)) .gt. dzero) then
        ! At column j starts a double pole
        ds = .false.
      else
        ! At column j+1 is a single pole
        if ((nuc .gt. 2) .and. (abs(A(j+1,j-1)) .gt. dzero)) then
          ! At columns j-1:j is a double pole, so we shift one more
          j = j - 1
          jm = jm - 1
          ds = .false.
        else
          ! At column j is also a single pole
          ds = .true.
        end if
      end if
      ! Swap the identified one to the front
      do while (jm .lt. cendm-2)
        if (ds) then
          ! Swapping 2 1x1
          if (jm .lt. cendm-3) then
            if (abs(A(j+4,j+2)) .gt. dzero) then
              call d_swap12(j+2, j+1, A, B, .true., apCI, apTI, &
                   QM, .true., jm+2, ZM, .true., jm+1)
              call d_swap12(j+1, j, A, B, .true., apCI, apTI, &
                   QM, .true., jm+1, ZM, .true., jm)
              j = j + 2
              jm = jm + 2
            else
              call d_swap11(j+2, j+1, A, B, .true., apCI, apTI, &
                   QM, .true., jm+2, ZM, .true., jm+1)
              call d_swap11(j+1, j, A, B, .true., apCI, apTI, &
                   QM, .true., jm+1, ZM, .true., jm)
              j = j + 1
              jm = jm + 1
            end if
          else
            call d_swap11(j+2, j+1, A, B, .true., apCI, apTI, &
                 QM, .true., jm+2, ZM, .true., jm+1)
            call d_swap11(j+1, j, A, B, .true., apCI, apTI, &
                 QM, .true., jm+1, ZM, .true., jm)
            j = j + 1
            jm = jm + 1
          end if
        else
          ! Swapping 2x2 block
          if (jm .lt. cendm-3) then
            if (abs(A(j+4,j+2)) .gt. dzero) then
              call d_swap22(j+1, j, A, B, .true., apCI, apTI, &
                   QM, .true., jm+1, ZM, .true., jm)
              j = j + 2
              jm = jm + 2
            else
              call d_swap21(j+1, j, A, B, .true., apCI, apTI, &
                   QM, .true., jm+1, ZM, .true., jm)
              j = j + 1
              jm = jm + 1
            end if
          else
            call d_swap21(j+1, j, A, B, .true., apCI, apTI, &
                 QM, .true., jm+1, ZM, .true., jm)
            j = j + 1
            jm = jm + 1
          end if
        end if
      end do
    elseif ((sz .eq. 1) .and. (nuc .gt. 0)) then
      ! Look for 1x1 if not available a 2x2
      do while (jm .gt. jmin)
        if (abs(A(j+1,j-1)) .gt. dzero) then
          j = j - 2
          jm = jm - 2
        else
          exit
        end if
      end do
      if (abs(A(j+1,j-1)) .gt. dzero) then
        ! We acctually did not find a 1x1
        sz = 2
        call moveLucSzToEnd(A,B,apCI,apTI,sz,cendm,nc,nuc,nbuf)
        return
      end if
      ! We swap the 1x1 to the end
      do while (jm .lt. cendm-1)
        if (jm .lt. cendm-2) then
          if (abs(A(j+3,j+1)) .gt. dzero) then
            call d_swap12(j+1, j, A, B, .true., apCI, apTI, &
                  QM, .true., jm+1, ZM, .true., jm)
            j = j + 2
            jm = jm + 2
          else
            call d_swap11(j+1, j, A, B, .true., apCI, apTI, &
                  QM, .true., jm+1, ZM, .true., jm)
            j = j + 1
            jm = jm + 1
          end if
        else
          call d_swap11(j+1, j, A, B, .true., apCI, apTI, &
                QM, .true., jm+1, ZM, .true., jm)
          j = j + 1
          jm = jm + 1
        end if
      end do
    else
      sz = -1 ! We cannot find a desired option
    end if
  end subroutine

end module


module nodal_stencil_module

  use bl_constants_module
  use bl_types
  use multifab_module
  use bc_functions_module
  use impose_neumann_bcs_module
  use stencil_types_module

  implicit none

  public :: set_faces_edges_corners_2d,set_faces_edges_corners_3d

contains

  subroutine s_1d_nodal(ss, sg, mm, dh)
    real (kind = dp_t), intent(inout) :: ss(0:)
    real (kind = dp_t), intent(inout) :: sg(0:)
    integer           , intent(in   ) :: mm(:)
    real (kind = dp_t), intent(in   ) :: dh(:)

    integer            :: nx
    real (kind = dp_t) :: f1

    nx = size(sg,dim=1) - 2

    if (bc_neumann(mm( 1),1,-1)) sg( 0) = sg(   1)
    if (bc_neumann(mm(nx),1,+1)) sg(nx) = sg(nx-1)

    f1 = ONE/dh(1)**2

    ss(:) = f1 * sg(:)

  end subroutine s_1d_nodal

  subroutine s_2d_nodal(ss, sg, mm, dh, lo, hi)

    integer           , intent(in   ) :: lo(:), hi(:)
    real (kind = dp_t), intent(inout) :: ss(lo(1)-1:,lo(2)-1:)
    real (kind = dp_t), intent(inout) :: sg(lo(1)-1:,lo(2)-1:)
    integer           , intent(in   ) :: mm(lo(1)  :,lo(2)  :)
    real (kind = dp_t), intent(in   ) :: dh(:)

    real (kind = dp_t) :: fac

    call set_faces_edges_corners_2d(sg, mm, lo, hi)

    ! This is not the full scaling for either stencil
    !   -- the cross stencil will need a factor of (1/2)
    !   -- the dense stencil will need a factor of (1/3)
    fac = ONE / (dh(1))**2

    ss(:,:) = fac * sg(:,:)

  end subroutine s_2d_nodal

  subroutine s_3d_nodal(ss, sg, mm, dh, lo, hi)

    integer           , intent(in   ) :: lo(:), hi(:)
    real (kind = dp_t), intent(inout) :: ss(0:,0:,0:)
    real (kind = dp_t), intent(inout) :: sg(0:,0:,0:)
    integer           , intent(inout) :: mm(:,:,:)
    real (kind = dp_t), intent(in   ) :: dh(:)

    real (kind = dp_t) :: fac

    call set_faces_edges_corners_3d(sg, mm, lo, hi)

    ! This is the right scaling for the cross stencil
    ! We end up needing to multiply by four later when we
    !    use this in the dense stencil.
    fac = (FOURTH / (dh(1))**2)

    ss(:,:,:) = fac * sg(:,:,:)

  end subroutine s_3d_nodal

  subroutine set_faces_edges_corners_2d(sg, mm, lo, hi)

    integer           , intent(in   ) :: lo(:), hi(:)
    real (kind = dp_t), intent(inout) :: sg(lo(1)-1:,lo(2)-1:)
    integer           , intent(in   ) :: mm(lo(1)  :,lo(2)  :)

    integer :: i, j
    !
    ! Set sg on edges at a Neumann boundary.
    !
    do i = lo(1),hi(1)
       if (bc_neumann(mm(i,lo(2)  ),2,-1)) sg(i,lo(2)-1) = sg(i,lo(2))
       if (bc_neumann(mm(i,hi(2)+1),2,+1)) sg(i,hi(2)+1) = sg(i,hi(2))
    end do

    do j = lo(2),hi(2)
       if (bc_neumann(mm(lo(1)  ,j),1,-1)) sg(lo(1)-1,j) = sg(lo(1),j)
       if (bc_neumann(mm(hi(1)+1,j),1,+1)) sg(hi(1)+1,j) = sg(hi(1),j)
    end do

    !
    ! Note: we do the corners *after* each of the edges has been done.
    !
    if (bc_neumann(mm(lo(1)  ,lo(2)  ),1,-1)) sg(lo(1)-1,lo(2)-1) = sg(lo(1),lo(2)-1)
    if (bc_neumann(mm(lo(1)  ,hi(2)+1),1,-1)) sg(lo(1)-1,hi(2)+1) = sg(lo(1),hi(2)+1)

    if (bc_neumann(mm(hi(1)+1,lo(2)  ),1,+1)) sg(hi(1)+1,lo(2)-1) = sg(hi(1),lo(2)-1)
    if (bc_neumann(mm(hi(1)+1,hi(2)+1),1,+1)) sg(hi(1)+1,hi(2)+1) = sg(hi(1),hi(2)+1)

    if (bc_neumann(mm(lo(1)  ,lo(2)  ),2,-1)) sg(lo(1)-1,lo(2)-1) = sg(lo(1)-1,lo(2))
    if (bc_neumann(mm(hi(1)+1,lo(2)  ),2,-1)) sg(hi(1)+1,lo(2)-1) = sg(hi(1)+1,lo(2))

    if (bc_neumann(mm(lo(1)  ,hi(2)+1),2,+1)) sg(lo(1)-1,hi(2)+1) = sg(lo(1)-1,hi(2))
    if (bc_neumann(mm(hi(1)+1,hi(2)+1),2,+1)) sg(hi(1)+1,hi(2)+1) = sg(hi(1)+1,hi(2))

  end subroutine set_faces_edges_corners_2d

  subroutine set_faces_edges_corners_3d(sg, mm, lo, hi)

    integer           , intent(in   ) :: lo(:), hi(:)
    real (kind = dp_t), intent(inout) :: sg(lo(1)-1:,lo(2)-1:,lo(3)-1:)
    integer           , intent(in   ) :: mm(lo(1)  :,lo(2)  :,lo(3)  :)

    integer :: i, j, k
    !
    ! Set sg on faces at a Neumann boundary.
    !
    do j = lo(2),hi(2)
    do i = lo(1),hi(1)
       if (bc_neumann(mm(i,j,lo(3)  ),3,-1)) sg(i,j,lo(3)-1) = sg(i,j,lo(3))
       if (bc_neumann(mm(i,j,hi(3)+1),3,+1)) sg(i,j,hi(3)+1) = sg(i,j,hi(3))
    end do
    end do

    do k = lo(3),hi(3)
    do i = lo(1),hi(1)
       if (bc_neumann(mm(i,lo(2)  ,k),2,-1)) sg(i,lo(2)-1,k) = sg(i,lo(2),k)
       if (bc_neumann(mm(i,hi(2)+1,k),2,+1)) sg(i,hi(2)+1,k) = sg(i,hi(2),k)
    end do
    end do

    do k = lo(3),hi(3)
    do j = lo(2),hi(2)
       if (bc_neumann(mm(lo(1)  ,j,k),1,-1)) sg(lo(1)-1,j,k) = sg(lo(1),j,k)
       if (bc_neumann(mm(hi(1)+1,j,k),1,+1)) sg(hi(1)+1,j,k) = sg(hi(1),j,k)
    end do
    end do

    !
    ! Set sg on edges at a Neumann boundary.
    !
    do i = lo(1),hi(1)
       if (bc_neumann(mm(lo(1),lo(2)  ,lo(3)  ),2,-1)) sg(i,lo(2)-1,lo(3)-1) = sg(i,lo(2),lo(3)-1)
       if (bc_neumann(mm(lo(1),lo(2)  ,hi(3)+1),2,-1)) sg(i,lo(2)-1,hi(3)+1) = sg(i,lo(2),hi(3)+1)

       if (bc_neumann(mm(lo(1),hi(2)+1,lo(3)  ),2,+1)) sg(i,hi(2)+1,lo(3)-1) = sg(i,hi(2),lo(3)-1)
       if (bc_neumann(mm(lo(1),hi(2)+1,hi(3)+1),2,+1)) sg(i,hi(2)+1,hi(3)+1) = sg(i,hi(2),hi(3)+1)

       if (bc_neumann(mm(lo(1),lo(2)  ,lo(3)  ),3,-1)) sg(i,lo(2)-1,lo(3)-1) = sg(i,lo(2)-1,lo(3))
       if (bc_neumann(mm(lo(1),hi(2)+1,lo(3)  ),3,-1)) sg(i,hi(2)+1,lo(3)-1) = sg(i,hi(2)+1,lo(3))

       if (bc_neumann(mm(lo(1),lo(2)  ,hi(3)+1),3,+1)) sg(i,lo(2)-1,hi(3)+1) = sg(i,lo(2)-1,hi(3))
       if (bc_neumann(mm(lo(1),hi(2)+1,hi(3)+1),3,+1)) sg(i,hi(2)+1,hi(3)+1) = sg(i,hi(2)+1,hi(3))
    end do

    do j = lo(2),hi(2)
       if (bc_neumann(mm(lo(1)  ,j,lo(3)  ),1,-1)) sg(lo(1)-1,j,lo(3)-1) = sg(lo(1),j,lo(3)-1)
       if (bc_neumann(mm(lo(1)  ,j,hi(3)+1),1,-1)) sg(lo(1)-1,j,hi(3)+1) = sg(lo(1),j,hi(3)+1)

       if (bc_neumann(mm(hi(1)+1,j,lo(3)  ),1,+1)) sg(hi(1)+1,j,lo(3)-1) = sg(hi(1),j,lo(3)-1)
       if (bc_neumann(mm(hi(1)+1,j,hi(3)+1),1,+1)) sg(hi(1)+1,j,hi(3)+1) = sg(hi(1),j,hi(3)+1)

       if (bc_neumann(mm(lo(1)  ,j,lo(3)  ),3,-1)) sg(lo(1)-1,j,lo(3)-1) = sg(lo(1)-1,j,lo(3))
       if (bc_neumann(mm(hi(1)+1,j,lo(3)  ),3,-1)) sg(hi(1)+1,j,lo(3)-1) = sg(hi(1)+1,j,lo(3))

       if (bc_neumann(mm(lo(1)  ,j,hi(3)+1),3,+1)) sg(lo(1)-1,j,hi(3)+1) = sg(lo(1)-1,j,hi(3))
       if (bc_neumann(mm(hi(1)+1,j,hi(3)+1),3,+1)) sg(hi(1)+1,j,hi(3)+1) = sg(hi(1)+1,j,hi(3))
    end do

    do k = lo(3),hi(3)
       if (bc_neumann(mm(lo(1)  ,lo(2)  ,k),1,-1)) sg(lo(1)-1,lo(2)-1,k) = sg(lo(1),lo(2)-1,k)
       if (bc_neumann(mm(lo(1)  ,hi(2)+1,k),1,-1)) sg(lo(1)-1,hi(2)+1,k) = sg(lo(1),hi(2)+1,k)

       if (bc_neumann(mm(hi(1)+1,lo(2)  ,k),1,+1)) sg(hi(1)+1,lo(2)-1,k) = sg(hi(1),lo(2)-1,k)
       if (bc_neumann(mm(hi(1)+1,hi(2)+1,k),1,+1)) sg(hi(1)+1,hi(2)+1,k) = sg(hi(1),hi(2)+1,k)

       if (bc_neumann(mm(lo(1)  ,lo(2)  ,k),2,-1)) sg(lo(1)-1,lo(2)-1,k) = sg(lo(1)-1,lo(2),k)
       if (bc_neumann(mm(hi(1)+1,lo(2)  ,k),2,-1)) sg(hi(1)+1,lo(2)-1,k) = sg(hi(1)+1,lo(2),k)

       if (bc_neumann(mm(lo(1)  ,hi(2)+1,k),2,+1)) sg(lo(1)-1,hi(2)+1,k) = sg(lo(1)-1,hi(2),k)
       if (bc_neumann(mm(hi(1)+1,hi(2)+1,k),2,+1)) sg(hi(1)+1,hi(2)+1,k) = sg(hi(1)+1,hi(2),k)
    end do

    if (bc_neumann(mm(lo(1),lo(2),lo(3)),1,-1)) sg(lo(1)-1,lo(2)-1,lo(3)-1) = sg(lo(1)  ,lo(2)-1,lo(3)-1)
    if (bc_neumann(mm(lo(1),lo(2),lo(3)),2,-1)) sg(lo(1)-1,lo(2)-1,lo(3)-1) = sg(lo(1)-1,lo(2)  ,lo(3)-1)
    if (bc_neumann(mm(lo(1),lo(2),lo(3)),3,-1)) sg(lo(1)-1,lo(2)-1,lo(3)-1) = sg(lo(1)-1,lo(2)-1,lo(3)  )

    if (bc_neumann(mm(hi(1)+1,lo(2),lo(3)),1,+1)) sg(hi(1)+1,lo(2)-1,lo(3)-1) = sg(hi(1)  ,lo(2)-1,lo(3)-1)
    if (bc_neumann(mm(hi(1)+1,lo(2),lo(3)),2,-1)) sg(hi(1)+1,lo(2)-1,lo(3)-1) = sg(hi(1)+1,lo(2)  ,lo(3)-1)
    if (bc_neumann(mm(hi(1)+1,lo(2),lo(3)),3,-1)) sg(hi(1)+1,lo(2)-1,lo(3)-1) = sg(hi(1)+1,lo(2)-1,lo(3))

    if (bc_neumann(mm(lo(1),hi(2)+1,lo(3)),1,-1)) sg(lo(1)-1,hi(2)+1,lo(3)-1) = sg(lo(1)  ,hi(2)+1, lo(3)-1)
    if (bc_neumann(mm(lo(1),hi(2)+1,lo(3)),2,+1)) sg(lo(1)-1,hi(2)+1,lo(3)-1) = sg(lo(1)-1,hi(2)  , lo(3)-1)
    if (bc_neumann(mm(lo(1),hi(2)+1,lo(3)),3,-1)) sg(lo(1)-1,hi(2)+1,lo(3)-1) = sg(lo(1)-1,hi(2)+1, lo(3)  )

    if (bc_neumann(mm(lo(1),lo(2),hi(3)+1),1,-1)) sg(lo(1)-1,lo(2)-1,hi(3)+1) = sg(lo(1)  ,lo(2)-1,hi(3)+1)
    if (bc_neumann(mm(lo(1),lo(2),hi(3)+1),2,-1)) sg(lo(1)-1,lo(2)-1,hi(3)+1) = sg(lo(1)-1,lo(2)  ,hi(3)+1)
    if (bc_neumann(mm(lo(1),lo(2),hi(3)+1),3,+1)) sg(lo(1)-1,lo(2)-1,hi(3)+1) = sg(lo(1)-1,lo(2)-1,hi(3)  )

    if (bc_neumann(mm(hi(1)+1,hi(2)+1,lo(3)),1,+1)) sg(hi(1)+1,hi(2)+1,lo(3)-1) = sg(hi(1)  ,hi(2)+1, lo(3)-1)
    if (bc_neumann(mm(hi(1)+1,hi(2)+1,lo(3)),2,+1)) sg(hi(1)+1,hi(2)+1,lo(3)-1) = sg(hi(1)+1,hi(2)  , lo(3)-1)
    if (bc_neumann(mm(hi(1)+1,hi(2)+1,lo(3)),3,-1)) sg(hi(1)+1,hi(2)+1,lo(3)-1) = sg(hi(1)+1,hi(2)+1, lo(3)  )

    if (bc_neumann(mm(hi(1)+1,lo(2),hi(3)+1),1,+1)) sg(hi(1)+1,lo(2)-1,hi(3)+1) = sg(hi(1)  ,lo(2)-1,hi(3)+1)
    if (bc_neumann(mm(hi(1)+1,lo(2),hi(3)+1),2,-1)) sg(hi(1)+1,lo(2)-1,hi(3)+1) = sg(hi(1)+1,lo(2)  ,hi(3)+1)
    if (bc_neumann(mm(hi(1)+1,lo(2),hi(3)+1),3,+1)) sg(hi(1)+1,lo(2)-1,hi(3)+1) = sg(hi(1)+1,lo(2)-1,hi(3)  )

    if (bc_neumann(mm(lo(1),hi(2)+1,hi(3)+1),1,-1)) sg(lo(1)-1,hi(2)+1,hi(3)+1) = sg(lo(1)  ,hi(2)+1,hi(3)+1)
    if (bc_neumann(mm(lo(1),hi(2)+1,hi(3)+1),2,+1)) sg(lo(1)-1,hi(2)+1,hi(3)+1) = sg(lo(1)-1,hi(2)  ,hi(3)+1)
    if (bc_neumann(mm(lo(1),hi(2)+1,hi(3)+1),3,+1)) sg(lo(1)-1,hi(2)+1,hi(3)+1) = sg(lo(1)-1,hi(2)+1,hi(3)  )

    if (bc_neumann(mm(hi(1)+1,hi(2)+1,hi(3)+1),1,+1)) sg(hi(1)+1,hi(2)+1,hi(3)+1) = sg(hi(1)  ,hi(2)+1,hi(3)+1)
    if (bc_neumann(mm(hi(1)+1,hi(2)+1,hi(3)+1),2,+1)) sg(hi(1)+1,hi(2)+1,hi(3)+1) = sg(hi(1)+1,hi(2)  ,hi(3)+1)
    if (bc_neumann(mm(hi(1)+1,hi(2)+1,hi(3)+1),3,+1)) sg(hi(1)+1,hi(2)+1,hi(3)+1) = sg(hi(1)+1,hi(2)+1,hi(3))

  end subroutine set_faces_edges_corners_3d

end module nodal_stencil_module


subroutine precip_init

! Initialize precipitation related stuff

use vars
use microphysics
use micro_params
use params

implicit none

real pratio, coef1, coef2,estw,esti,rrr1,rrr2
real*4 gammafff
external gammafff
integer k

gam3 = 3.
gamr1 = 3.+b_rain
gamr2 = (5.+b_rain)/2.
gamr3 = 4.+b_rain
gams1 = 3.+b_snow
gams2 = (5.+b_snow)/2.
gams3 = 4.+b_snow
gamg1 = 3.+b_grau
gamg2 = (5.+b_grau)/2.
gamg3 = 4.+b_grau
gam3 = gammafff(gam3)
gamr1 = gammafff(gamr1)
gamr2 = gammafff(gamr2)
gamr3 = gammafff(gamr3)
gams1 = gammafff(gams1)
gams2 = gammafff(gams2)
gams3 = gammafff(gams3)
gamg1 = gammafff(gamg1)
gamg2 = gammafff(gamg2)
gamg3 = gammafff(gamg3)
!if(masterproc) then
! print*,'gam3=',gam3
! print*,'gamr1,gamr2,gamr3:',gamr1,gamr2,gamr3
! print*,'gams1,gams2,gams3:',gams1,gams2,gams3
! print*,'gamg1,gamg2,gamg3:',gamg1,gamg2,gamg3
!endif
if(nint(gam3).ne.2) then
   if(masterproc)print*,'cannot compute gamma-function in precip_init. Exiting...'
   call task_abort
end if

do k=1,nzm

! pratio = (1000. / pres(k)) ** 0.4
  pratio = sqrt(1.29 / rho(k))

  rrr1=393./(tabs0(k)+120.)*(tabs0(k)/273.)**1.5
  rrr2=(tabs0(k)/273.)**1.94*(1000./pres(k))

  estw = 100.*esatw(tabs0(k))
  esti = 100.*esati(tabs0(k))

! accretion by snow:

  coef1 = 0.25 * pi * nzeros * a_snow * gams1 * pratio/ &
            (pi * rhos * nzeros/rho(k) ) ** ((3+b_snow)/4.)
  coef2 = exp(0.025*(tabs0(k) - 273.15))
  accrsi(k) =  coef1 * coef2 * esicoef
  accrsc(k) =  coef1 * esccoef
  coefice(k) =  coef2

! evaporation of snow:

  coef1  =(lsub/(tabs0(k)*rv)-1.)*lsub/(therco*rrr1*tabs0(k))
  coef2  = rv*tabs0(k)/(diffelq*rrr2*esti)
  evaps1(k)  =  0.65*4.*nzeros/sqrt(pi*rhos*nzeros)/(coef1+coef2)/sqrt(rho(k))
  evaps2(k)  =  0.49*4.*nzeros*gams2*sqrt(a_snow/(muelq*rrr1))/ &
       (pi*rhos*nzeros)**((5+b_snow)/8.) / (coef1+coef2) &
               * rho(k)**((1+b_snow)/8.)*sqrt(pratio)

! accretion by graupel:

  coef1 = 0.25*pi*nzerog*a_grau*gamg1*pratio/&
          (pi*rhog*nzerog/rho(k))**((3+b_grau)/4.)
  coef2 = exp(0.025*(tabs0(k) - 273.15))
  accrgi(k) =  coef1 * coef2 * egicoef
  accrgc(k) =  coef1 * egccoef

! evaporation of graupel:

  coef1  =(lsub/(tabs0(k)*rv)-1.)*lsub/(therco*rrr1*tabs0(k))
  coef2  = rv*tabs0(k)/(diffelq*rrr2*esti)
  evapg1(k)  = 0.65*4.*nzerog/sqrt(pi*rhog*nzerog)/(coef1+coef2)/sqrt(rho(k))
  evapg2(k)  = 0.49*4.*nzerog*gamg2*sqrt(a_grau/(muelq*rrr1))/ &
        (pi * rhog * nzerog)**((5+b_grau)/8.) / (coef1+coef2) &
               * rho(k)**((1+b_grau)/8.)*sqrt(pratio)

! accretion by rain:

  accrrc(k)=  0.25 * pi * nzeror * a_rain * gamr1 * pratio/ &
              (pi * rhor * nzeror / rho(k)) ** ((3+b_rain)/4.)* erccoef

! evaporation of rain:

  coef1  =(lcond/(tabs0(k)*rv)-1.)*lcond/(therco*rrr1*tabs0(k))
  coef2  = rv*tabs0(k)/(diffelq * rrr2 * estw)
  evapr1(k)  =  0.78 * 2. * pi * nzeror / &
        sqrt(pi * rhor * nzeror) / (coef1+coef2) / sqrt(rho(k))
  evapr2(k)  =  0.31 * 2. * pi  * nzeror * gamr2 * &
		0.89 * sqrt(a_rain/(muelq*rrr1))/ &
        (pi * rhor * nzeror)**((5+b_rain)/8.) / (coef1+coef2) &
             * rho(k)**((1+b_rain)/8.)*sqrt(pratio)

end do

end subroutine precip_init