*=======================================================================
* File:    dlphs2.f
* Author:  Alex Stivala, based on spphase1.m by Prof. Yinyu Ye.
* Created: July 2008
*
* This is a reimplementation using FORTRAN-77 and LAPACK
* of spphase1.m from Prof. Yinyu Ye
* http://www.stanford.edu/~yyye/matlab/spphase2.m
*
* Note that the original MATLAB code uses MATLAB sparse matrix
* facilities, implemented in MATALB with the CHOLMOD routines
* from Tim Davis et al. LAPACK is for dense systems, this implementation
* uses just LAPACK so does not use sparseness (hence no 'sp' prefix
* on name, 'dl' is for 'dense LAPACK').
*
* This appears to be faster than the sparse version (spphs2.f) which
* uses UMFPACK though.
*
* $Id: dlphs2.F 2969 2009-11-22 01:29:39Z astivala $
*=======================================================================

      subroutine dlphs2(Q, ldq, A, lda, m, n, c, alpha, beta, lambda,
     $     toler, obvalue, ob,
     $     x, y, E, lde, u, ldu, xxvec, gg, XX, ldxx,
     $     AA, ldaa, ipiv, wvec, Ewk, ldewk, work, lwork, info2)

      implicit none
*
* dlphs2 - phase 2 of dsoqp:
*          Repeatedly solve an ellipsoid constrained QP problem
*          by solving a linear system until a positive solution is
*          found.
*
*     .. Scalar Arguments ..
      integer            ldq,lda,m,n,lde,ldxx,ldaa,ldu,ldewk,lwork,info2
      double precision   alpha,beta,lambda,toler,obvalue,ob
*     ..
*     .. Array Arguments ..
      double precision   Q(ldq,*),A(lda,*),c(*),x(*),y(*),
     $     E(lde, *),u(*),xxvec(*),gg(*),XX(ldxx,*),
     $     AA(ldaa, *), wvec(*),Ewk(ldewk, *),work(*)
      integer            ipiv(*)

*     ..
*
* The phase 1 procedure called by dlsoqp.
* For more details see dlsoqp.f.
*
* Arguments
* =========
*
* Q      (input) DOUBLE PRECISION array, dimension (n, n)
*        The symmetric objective matrix
*
*
* ldq    (input) INTGER
*        leading dimension of Q. ldq >= n
*
* A      (input) DOUBLE PRECISION array, dimension (m, n)
*        the constraint left-hand matrix
*
* lda    (input) INTGER
*        leading dimension of A. lda >= m
*
* m      (input) INTEGER
*        number of rows in matrix A
*
* n      (input) INTEGER
*        number of columns in matrix A
*
* c      (input) DOUBLE PRECISION vector, dimension(n)
*        objective column vector
*
* alpha  (input) DOUBLE PRECISION
*        solution descent parameter
*
* beta   (input) DOUBLE PRECISION
*        step size 0 < beta < 1
*
* lambda (input/output) DOUBLE PRECISION
*        solution descent parameter
*
* toler  (input) DOUBLE PRECISION
*        relative stopping tolerance
*
* obvalue (input) DOUBLE PRECISION
*        previous objective value
*
* ob     (input/output) DOUBLE PRECISION
*        objective value
*
* x      (input/output) DOUBLE PRECISION vector, dimension (n)
*        solution vector
*
* y      (output) DOUBLE PRECISION vector, dimension (m)
*        optimal dual solution (Lagrangian multiplier)
*
* E      (output) DOUBLE PRECISION, dimension (m+n, m+n)
*        workspace
*
* lde    (input) INTEGER
*        leading dimension of E. lde >= m+n
*
* u      (output) DOUBLE PREISION vector, dimension (m+n)
*        workspace
*
* ldu    (input) INTEGER
*        leading dimension of u, ldu >= m+n
*
* xxvec  (output) DOUBLE PRECISION vector, dimension (n)
*        workspace
*
* gg     (output) DOUBLE PRECISION vector, dimension (n)
*        workspace
*
* XX     (output) DOUBLE PRECISION, dimension (n, n)
*        workspace
*
* ldxx   (input) INTEGER
*        leading dimension of XX. ldxx >= n
*
* AA     (output) DOUBLE PRECISION, dimension (m, n)
*        workspace
*
* ldaa   (input) INTEGER
*        leading dimension of AA. ldaa >= m.
*
* ipiv   (output) INTEGER, dimension (m+n)
*        workspace
*
* wvec    (output) DOUBLE PRECISION, dimension (n)
*        workspace
*
* Ewk    (output) DOUBLE PRECISION, dimension (m+n, m+n)
*        workspace
*
* ldewk  (input) INTEGER
*        leading dimension of Ewk. lde >= m+n
*
* work   (output) DOUBLE PRECISION vector, dimension (lwork)
*        workspace for DSYSV
*
* lwork  (input) INTEGER
*        length of work vector. lwork >= (m+n)*NB where NB is optimal
*        blocksize for DSYTRF.
*
* info2  (output) INTEGER
*        = 0  : successful
*        = 999: the problem seems unbounded
*       other : info code from LAPACK
*
*=======================================================================
*

*     .. Parameters ..
*     eps is the machine epsilon for double precision
*     this is for GNU FORTRAN (g77) on Linux x86/64
*     MAY NEED CHANGING ON DIFFERENT SYSTEMS/COMPILERS
      double precision eps
      parameter (eps = 2.2204d-16)
      double precision infty
      parameter (infty=1.79769d+308)
      double precision neginf
      parameter (neginf=-1.79769d+308)
*     ..
*     .. Local Scalars ..
      integer i,j,info,nrhs,incr,order,edim
      double precision w1,w2,blasa,blasb,nora,valgo
      character uplo
*     ..
*     .. Local Arrays ..

*     ..
*     .. Intrinsic Functions ..
      intrinsic min,abs
*     ..
*     .. External Subroutines and Functions ..
      external demvv
      double precision dvmin
      external dvmin
*     LAPACK subroutines
      external dlange,dpotrf,dpotrs,dpocon,dsysv
*     BLAS level 1 subroutines/functions
      external daxpy,dscal,dcopy
      double precision ddot
      external ddot
*     BLAS level 2 subroutines
      external dsymv
*     BLAS level 3 subroutines

*     ..
*     .. Executable Statements ..
*

*     ==================================================================
*
*     Repeatedly solve the ellipsoid constrained QP problem by solving
*     the linear system
*
*     E*u = F where
*
*     E (m+n, m+n)  =    ( XXlam (n, n)   AA' (n, m) )
*                        ( AA    (m, n)    0  (m, m) )
*
*     F (m+n)       =    ( dx (n, 1) )
*                        ( 0  (m, 1) )
*
*     dx (n, 1) is elementwise -x.*gg where gg = Q*x+c
*     XXlam = XX + lambda*eye(n,n) where XX = dx * Q * dx
*                                  where dx(n) is x along diagonal
*
*     until a positive solution is found.
*
*     Inside the loop, only the top left submatrix of E is updated
*     (lambda is modified), other 3 submatrices are constant.
*     However since DSYSV stores the U*D*U**T
*     decomposition in this matrix parameter, must rebuild
*     entire matrix each time in the loop.
*     Profiling showed doing this was the majority of time spent
*     in program, so rather than rebuilding entirely we build
*     it first outside the loop in another array,
*     then inside at each iteration
*     copy the one built outside the loop into working array E
*     using BLAS level 1 DCOPY on columns, then update the
*     top left part by adding lambda to diagonal elements.
*     XX can be computed only once before the loop though,
*     and used in rebuilding E in the loop. This really made little
*     or no difference though, most time still spend building E
*     (but now outside loop) - need to use sparseness.
*     Part of F is constant 0 as well, but in fact we do not even
*     have F, we just use storage u for both input 'F' and output
*     u since LAPACK subroutine DSYSV stores solution in rhs
*     matrix. So we rebuid u on each iteration, on exit of
*     loop u contains the solution vector we want.
*
*     XX (and therefore XXlam) is square, symmetric and sparse.
*     E is square, symmetric, and sparse.
*     It may be positive definite, which can efficiently be tested
*     for with Cholesky factorization, and solved by that means
*     more efficiently than the general case using LU decomposition.
*
*     ==================================================================

      lambda = (1.0d0 - beta) * lambda

      valgo = 0.0d0

*     usually using increment of 1 in BLAS calls
      incr = 1

*     gg = Q*x + c
*     Q is symmetric  (using upper tri arbitrarily here)
*     stored in gg not directly in F(1:n) as used again later
      call dcopy(n, c, incr, gg, incr)
      uplo = 'U'
      blasa = 1.0d0
      blasb = 1.0d0
      call dsymv(uplo, n, blasa, Q, ldq, x, incr, blasb, gg, incr)

*     dx = diagonal matrix with x along main diagonal
*     AA = A*dx
*     XX = dx*Q*dx
*     since XX is diagonal we can compute
*     XX <- A*dx and
*     XX <- Q*dx just by
*     scaling each column by x(j) for j=1,n
*     then finally we can compute
*     XX <- dx*XX
*     by scaling each ROW by x(i) for i = 1,n
*     with only BLAS level 1 subroutines DCOPY and DSCAL,
*     although the last one is row-wise so inefficient memory access
*     in FORTRAN.
      do 10 j = 1,n
         call dcopy(m, A(1, j), incr, AA(1, j), incr)
         call dscal(m, x(j), AA(1, j), incr)
         call dcopy(n, Q(1, j), incr, XX(1, j), incr)
         call dscal(n, x(j), XX(1, j), incr)
 10   continue
      do 20 i = 1,n
*        NB using INCX=ldxx to scale rows not columns of XX
         call dscal(n, x(i), XX(i, 1), ldxx)
 20   continue

*     E and its template Ewk are m+n square matrices
      edim = n + m

*     Build the Ewk matrix to be copied to E for input to DSYSV, since
*     DSYSV writes U*D*U**T decomposition over it so need top copy back
*     each iteration, then update by adding lambda. It is symmetric, we
*     will only build the upper triangle.
         do 130 j = 1, n
            call dcopy(j, XX(1,j), incr, Ewk(1,j), incr)
 130     continue
         do 170 j = 1, m
*           note use of INCX=ldaa for AA to get rows
            call dcopy(n, AA(j, 1), ldaa, Ewk(1,n+j), incr)
 170     continue
         do 190 j = n+1, edim
            do 180 i = n+1, j
               Ewk(i, j) = 0.0d0
 180        continue
 190     continue

*     Also since Q, AA, XX, XXlam all symmetric, should only store
*     one triangle. AA, XX, XXlam also are
*     all sparse so should also be more efficient to use specialized
*     routines rather than BLAS and LAPACK (as MATLAB does in the
*     MATLAB implementaton), but turns out actualy to be slower
*     when this was done using UMFPACK.

 200  if (valgo .le. 0.0d0) then

*        copy Ewk to E since previous E overwritten by DSYSV solution
*        and update E by adding lambda along diagonal elements of XX
*        submatrix in top left
*        only using upper triangle
         do 210 j = 1, n
            call dcopy(j, Ewk(1, j), incr, E(1, j), incr)
            E(j, j) = E(j, j) + lambda
 210     continue
         do 220 j = n+1, edim
            call dcopy(j, Ewk(1, j), incr, E(1, j), incr)
 220     continue

*        u(1:n) = -x .* gg
         call dcopy(n, x, incr, u, incr)
         call demvv(n, gg, u)
         blasa = -1.0d0
         call dscal(n, blasa, u, incr)
*        u(n+1:n+m) = 0
         do 300 i = n+1, edim
            u(i) = 0.0d0
 300     continue

C          write(*,380),( (E(i,j), j=1,m+n), i=1,m+n)
C  380     format (21(f8.4))

*     TODO: use DPOTRS to solve if postive definite, test with DPOTRF

         order = m + n
         nrhs = 1
         uplo = 'U'
         call dsysv(uplo, order, nrhs, E, lde, ipiv, u, ldu,
     $        work, lwork, info)
         if (info .ne. 0) then
            write(*,*) 'dlphs2 DSYSV failed'
            info2 = info
            return
         endif
*        The solution is in u

*        xxvec = x + x .* u(1:n)
         call dcopy(n, x, incr, xxvec, incr)
         call demvv(n, u, xxvec)
         blasa = 1.0d0
         call daxpy(n, blasa, x, incr, xxvec, incr)

         valgo = dvmin(n, xxvec)
         if (valgo .gt. 0.0d0) then
*           ob = (xxvec' * Q * xxvec)/2 + c'*xxvec
            uplo = 'U'
            blasa = 1.0d0
            blasb = 0.0d0
*           blasb is zero so wvec can be uninitialized on entry to DSYMV
            call dsymv(uplo, n, blasa, Q, ldq, xxvec, incr, blasb,
     $                 wvec, incr)
            ob = ddot(n, xxvec, incr, wvec, incr) / 2.0d0 +
     $           ddot(n, c, incr, xxvec, incr)

C            write(*,399),valgo,obvalue,ob
C 399        format('valgo = ',f10.6,' obvalue = ',f10.6,
C     $           ' ob = ',f10.6)

            valgo = min(valgo, obvalue - ob + eps)
         endif
         lambda = 2.0d0 * lambda

C          write(*,400),lambda
C  400     format ('lambda = ',f12.6)

         if (lambda .ge. (1.0d0 + abs(obvalue))/toler) then
            write(*,*) 'The problem seems unbounded.'
            info2 = 999
            return
         endif
         goto 200
*     end of while (valgo .le .0.0) loop
      endif

*     y = -u(n+1:n+m)
      call dcopy(m, u(n+1), incr, y, incr)
      blasa = -1.0d0
      call dscal(m, blasa, y, incr)
*     from now on we only use first n elements of u
      nora = dvmin(n, u)
      if (nora .lt. 0.0d0) then
         nora = -alpha / nora
      elseif (nora .eq. 0.0d0) then
         nora = alpha
      else
         nora = infty
      endif

*     u = x.* u
*     w1 = u'*Q*u
*     w2 = -u'*gg
      call demvv(n, x, u)
      uplo = 'U'
      blasa = 1.0d0
      blasb = 0.0d0
*     blasb is zero so wvec can be uninitialized on entry to DSYMV
      call dsymv(uplo, n, blasa, Q, ldq, u, incr, blasb, wvec, incr)
      w1 = ddot(n, u, incr, wvec, incr)
      w2 = -1.0d0 * ddot(n, u, incr, gg, incr)
      if (w1 .gt. 0.0d0) then
         nora = min(w2/w1, nora)
      endif
      if (nora .eq. infty) then
         ob = neginf
      else
*        x = x + nora*u
         call daxpy(n, nora, u, incr, x, incr)
*        ob = (x' * Q * x)/2 + c'*x
         uplo = 'U'
         blasa = 1.0d0
         blasb = 0.0d0
*        blasb is zero so wvec can be uninitialized on entry to DSYMV
         call dsymv(uplo, n, blasa, Q, ldq, x, incr, blasb, wvec, incr)
         ob = ddot(n, x, incr, wvec, incr) / 2.0d0 +
     $        ddot(n, c, incr, x, incr)
      endif

*     end of DLPHS2 , phase 2 subroutine of DLSOQP.

      info2 = 0
      return
      end


subroutine trans_func(x,y,m,xx,yy,n,xxx,yyy,zzz,d,wavelen,root,newroot,g)
    implicit none
    real, parameter :: pi=3.141592653589793238460

    integer x,y,xx,yy,xxx,yyy,zzz
    real m(x,y),n(xx,yy), nn(xx,yy), mm(x,y)
    real, dimension(x,yy), intent(out) :: root
    real d(xxx,yyy,zzz)
    real wavelen

    integer i,j
    complex, dimension(x,yy), intent(out) :: newroot
    complex, dimension(x,yy,zzz), intent(out) :: g
    complex jj

!    print*, shape(m)
!    print*, shape(n)
!    print*, shape(d)
!    nn= transpose(n)
!    print*, shape(nn)

    mm = (wavelen*m)*(wavelen*m)
    nn = (wavelen*n)*(wavelen*n)

!    print*, 'mm,nn'
!    print*, shape(mm)
!    print*, shape(nn)

    do j=1,yy
        do i=1,x
            root(j,i) =  1 - nn(1,j) - mm(i,1)
        enddo
    enddo

    where (root .ge. 0)
        root = root !* root
    elsewhere
        root = 0
    endwhere

    jj = cmplx(0,1)

    newroot = cmplx(root,0)

    do i=1, zzz
        !g(:,:,i) = (-1*jj*2*pi*d(1,1,i)/wavelen)*sqrt(newroot)

        g(:,:,i) = exp((-1*jj*2*pi*d(1,1,i)/wavelen)*sqrt(newroot))

        !print*, g(:,:,i)
    enddo

    !g = exp(g)

    !g = (-1*jj*2*pi*d/wavelen)*sqrt(root)

    return
end

subroutine faster_trans_func(x,y,m,xx,yy,n,xxx,yyy,zzz,d,wavelen,g)
    implicit none
    real, parameter :: pi=3.141592653589793238460

    integer x,y,xx,yy,xxx,yyy,zzz
    real m(x,y),n(xx,yy), nn(xx,yy), mm(x,y)
    real, dimension(x,yy) :: root
    real d(xxx,yyy,zzz)
    real wavelen

    integer i,j
    complex, dimension(x,yy) :: newroot
    complex, dimension(x,yy,zzz), intent(out) :: g
    complex jj
    !integer*8 t1,t2,t3,t4

    mm = (wavelen*m)*(wavelen*m)
    nn = (wavelen*n)*(wavelen*n)

    !call system_clock(t1)

    do j=1,yy
        do i=1,x
            root(j,i) =  1 - nn(1,j) - mm(i,1)
        enddo
    enddo

    !call system_clock(t2)

    where (root .lt. 0)
        root = 0
    endwhere

    !call system_clock(t3)

    jj = cmplx(0,1)

    newroot = cmplx(root,0)
    newroot = sqrt(newroot)

    do i=1, zzz
        g(:,:,i) = (-1*jj*2*pi*d(1,1,i)/wavelen)*newroot
    enddo

    !call system_clock(t4)

    !where (root .ge. 0)
        !g = exp(g)*root

    return
end

subroutine test(xxx,yyy,zzz,d,wavelen,x,y,root,newroot,g)
    implicit none
    real, parameter :: pi=3.141592653589793238460

    integer x,y,xxx,yyy,zzz
    complex, dimension(x,y) :: root
    real d(xxx,yyy,zzz)
    real wavelen

    integer i
    complex, dimension(x,y), intent(out) :: newroot
    complex, dimension(x,y,zzz), intent(out) :: g
    complex jj

    jj = cmplx(0,1)

    !newroot = cmplx(root,0)
    newroot = sqrt(root)
    !newroot = sqrt(newroot)

    do i=1, zzz
        g(:,:,i) = (-1*jj*2*pi*d(1,1,i)/wavelen)*newroot
    enddo

    g = exp(g)

    return
end

subroutine fft(N,in,out)
    use, intrinsic :: iso_c_binding
    include 'fftw3.f03'
    double complex :: in
    double complex, optional, intent(out):: out
    dimension in(N), out(N)
    integer*8 plan

    call dfftw_plan_dft_1d(plan,N,in,out,FFTW_FORWARD,FFTW_ESTIMATE)
    call dfftw_execute_dft(plan, in, out)
    call dfftw_destroy_plan(plan)

    return

end subroutine

subroutine fft2(M,N,in,out)
    use, intrinsic :: iso_c_binding
    include 'fftw3.f03'
    double complex in
    dimension in(M,N)
    double complex, intent(out) :: out
    dimension out(M, N)
    integer*8 plan

    call dfftw_plan_dft_2d( plan,N,M, in,out, FFTW_FORWARD, FFTW_ESTIMATE)
    call dfftw_execute_dft(plan, in, out)
    call dfftw_destroy_plan(plan)

    return
    end


c ===============================================================
       subroutine calcaux(maxmx,meqn,mbc,mx,xlower,dx,q,maux,aux)
c ===============================================================
c
      implicit none

      double precision q(1-mbc:maxmx+mbc, meqn)
      double precision aux(1-mbc:maxmx+mbc, maux)

      integer maxmx,meqn,mbc,mx,maux
      double precision xlower,dx

      integer i,ma,ibc
      logical iflag(4)
      double precision h,u,m,pbed,rho,S,m_eqn,tanpsi,phi,compress,pms,
     &              kperm,tau,up,um,dudx,pm,sqrtarg,kappa,D,theta,g
      double precision sigbed

      include "digparamsdec.i"
      include "digparamscommon.i"

      g=grav

      do i=1,mx
         theta = aux(i,i_theta)
         phi = aux(i,i_phi)
         call admissibleq(theta,q(i,1),q(i,2),q(i,3),q(i,4),u,m,iflag)
         h=q(i,1)
         if (h.le.dry_tol) then
            aux(i,i_S) = 0.d0
            aux(i,i_rho) = 0.d0
            aux(i,i_tanpsi) = 0.d0
            aux(i,i_D) = 0.d0
            aux(i,i_tau) = 0.d0
            aux(i,i_kappa) = 1.d0
            aux(i,i_sigbed) = 0.d0
            aux(i,i_kperm) = 0.d0
            aux(i,i_alpha) = 0.d0
            cycle
         endif
         pbed = q(i,4)
         !write(*,*) 'pbed:',pbed
         if (q(i,1).gt.0.d0.and.q(i-1,1).gt.0.d0) then
            dudx = (q(i,2)/q(i,1) - q(i-1,2)/q(i-1,1))/dx
         else
            dudx = 0.d0
         endif
         pms = abs(tanh(dudx/dudx_eps))
         pm = sign(1.d0,dudx)

         call auxeval(h,u,m,pbed,kappa,theta,
     &              S,rho,tanpsi,D,tau,phi,sigbed,kperm,compress,pm)

         aux(i,i_S) = S
         aux(i,i_rho) = rho
         aux(i,i_tanpsi) = tanpsi
         aux(i,i_D) = D
         aux(i,i_tau) = tau
         aux(i,i_kappa) = kappa
         aux(i,i_sigbed) = sigbed
         aux(i,i_kperm) = kperm
         aux(i,i_alpha) = compress

      enddo

      do ibc = 1,mbc
         do ma = 1,maux
            aux(1-ibc,ma) = aux(1,ma)
            aux(mx+ibc,ma) = aux(mx,ma)
            enddo
         enddo

      return
      end


      PROGRAM DRIVER
C**************************************************************************
C     THIS IS THE DRIVER FOR CHECKING THE STANDALONE MATRIX ELEMENT.
C     IT USES A SIMPLE PHASE SPACE GENERATOR
C     Fabio Maltoni - 3rd Febraury 2007
C**************************************************************************
      IMPLICIT NONE
C
C     CONSTANTS
C
      REAL*8 ZERO
      PARAMETER (ZERO=0D0)
C
C     INCLUDE FILES
C
C---  the include file with the values of the parameters and masses
      INCLUDE "coupl.inc"
C---  integer nexternal ! number particles (incoming+outgoing) in the me
      INCLUDE "nexternal.inc"
C---  particle masses
      REAL*8 PMASS(NEXTERNAL)
      REAL*8 TOTALMASS
C---  integer    n_max_cg
      INCLUDE "ngraphs.inc"     !how many diagrams (could be useful to know...)

C
C     LOCAL
C
      INTEGER I,J,K
      REAL*8 P(0:3,NEXTERNAL)   ! four momenta. Energy is the zeroth component.
      REAL*8 SQRTS,MATELEM           ! sqrt(s)= center of mass energy
      REAL*8 PIN(0:3), POUT(0:3)
      CHARACTER*120 BUFF(NEXTERNAL)
C
C     EXTERNAL
C
      REAL*8 DOT
      EXTERNAL DOT

C-----
C     BEGIN CODE
C-----
C
C---  INITIALIZATION CALLS
C
c---  Call to initialize the values of the couplings, masses and widths
c     used in the evaluation of the matrix element. The primary parameters of the
c     models are read from Cards/param_card.dat. The secondary parameters are calculated
c     in Source/MODEL/couplings.f. The values are stored in common blocks that are listed
c     in coupl.inc .

      call setpara('param_card.dat')  !first call to setup the paramaters
      include "pmass.inc"             !set up masses

      TOTALMASS = 0.0d0
      DO I=1,NEXTERNAL
        TOTALMASS = TOTALMASS + PMASS(I)
      ENDDO

c---  Now use a simple multipurpose PS generator (RAMBO) just to get a
c     RANDOM set of four momenta of given masses pmass(i) to be used to evaluate
c     the MadGraph5_aMC@NLO matrix-element.
c     Alternatevely, here the user can call or set the four momenta at his will, see below.
c
      IF(nincoming.EQ.1) THEN
         SQRTS=PMASS(1)
      ELSE
         SQRTS=1000d0              !CMS energy in GEV
         IF (SQRTS.le.2.0d0*TOTALMASS) THEN
            SQRTS = 2.0d0*TOTALMASS
         ENDIF
      ENDIF

      call printout()

      CALL GET_MOMENTA(SQRTS,PMASS,P)
c
c	  write the information on the four momenta
c
      write (*,*)
      write (*,*) " Phase space point:"
      write (*,*)
      write (*,*) "-----------------------------------------------------------------------------"
      write (*,*)  "n        E             px             py              pz               m "
      do i=1,nexternal
         write (*,'(i2,1x,5e15.7)') i, P(0,i),P(1,i),P(2,i),P(3,i),
     .dsqrt(dabs(DOT(p(0,i),p(0,i))))
      enddo
      write (*,*) "-----------------------------------------------------------------------------"

c
c     Now we can call the matrix element!
c
      CALL SMATRIX(P,MATELEM)
c

      write (*,*) "Matrix element = ", MATELEM, " GeV^",-(2*nexternal-8)
      write (*,*) "-----------------------------------------------------------------------------"

cc
cc      Copy down here (or read in) the four momenta as a string.
cc
cc
c      buff(1)=" 1   0.5630480E+04  0.0000000E+00  0.0000000E+00  0.5630480E+04"
c      buff(2)=" 2   0.5630480E+04  0.0000000E+00  0.0000000E+00 -0.5630480E+04"
c      buff(3)=" 3   0.5466073E+04  0.4443190E+03  0.2446331E+04 -0.4864732E+04"
c      buff(4)=" 4   0.8785819E+03 -0.2533886E+03  0.2741971E+03  0.7759741E+03"
c      buff(5)=" 5   0.4916306E+04 -0.1909305E+03 -0.2720528E+04  0.4088757E+04"
cc
cc      Here the k,E,px,py,pz are read from the string into the momenta array.
cc      k=1,2          : incoming
cc      k=3,nexternal  : outgoing
cc
c      do i=1,nexternal
c         read (buff(i),*) k, P(0,i),P(1,i),P(2,i),P(3,i)
c      enddo
c
cc- print the momenta out
c
c      do i=1,nexternal
c         write (*,'(i2,1x,5e15.7)') i, P(0,i),P(1,i),P(2,i),P(3,i),
c     .dsqrt(dabs(DOT(p(0,i),p(0,i))))
c      enddo
c
c      CALL SMATRIX(P,MATELEM)
c
c      write (*,*) "-------------------------------------------------"
c      write (*,*) "Matrix element = ", MATELEM, " GeV^",-(2*nexternal-8)
c      write (*,*) "-------------------------------------------------"

      end

	   double precision function dot(p1,p2)
C****************************************************************************
C     4-Vector Dot product
C****************************************************************************
      implicit none
      double precision p1(0:3),p2(0:3)
      dot=p1(0)*p2(0)-p1(1)*p2(1)-p1(2)*p2(2)-p1(3)*p2(3)
      end

	  SUBROUTINE GET_MOMENTA(ENERGY,PMASS,P)
C---- auxiliary function to change convention between MadGraph5_aMC@NLO and rambo
c---- four momenta.
	  IMPLICIT NONE
	  INCLUDE "nexternal.inc"
C	  ARGUMENTS
	  REAL*8 ENERGY,PMASS(NEXTERNAL),P(0:3,NEXTERNAL),PRAMBO(4,10),WGT
C         LOCAL
         INTEGER I
         REAL*8 etot2,mom,m1,m2,e1,e2

         ETOT2=energy**2
         m1=pmass(1)
         m2=pmass(2)
         mom=(Etot2**2 - 2*Etot2*m1**2 + m1**4 -
     -        2*Etot2*m2**2 - 2*m1**2*m2**2 + m2**4)/(4.*Etot2)
         mom=dsqrt(mom)
         e1=DSQRT(mom**2+m1**2)
         e2=DSQRT(mom**2+m2**2)
         write (*,*) e1+e2,mom

         if(nincoming.eq.2) then

            P(0,1)=e1
            P(1,1)=0d0
            P(2,1)=0d0
            P(3,1)=mom

            P(0,2)=e2
            P(1,2)=0d0
            P(2,2)=0d0
            P(3,2)=-mom

            call rambo(nexternal-2,energy,pmass(nincoming+1),prambo,WGT)
            DO I=3, NEXTERNAL
               P(0,I)=PRAMBO(4,I-2)
               P(1,I)=PRAMBO(1,I-2)
               P(2,I)=PRAMBO(2,I-2)
               P(3,I)=PRAMBO(3,I-2)
            ENDDO

          elseif(nincoming.eq.1) then

             P(0,1)=energy
             P(1,1)=0d0
             P(2,1)=0d0
             P(3,1)=0d0

             call rambo(nexternal-1,energy,pmass(2),prambo,WGT)
             DO I=2, NEXTERNAL
                P(0,I)=PRAMBO(4,I-1)
                P(1,I)=PRAMBO(1,I-1)
                P(2,I)=PRAMBO(2,I-1)
                P(3,I)=PRAMBO(3,I-1)
             ENDDO
          endif

	  RETURN
	  END

      SUBROUTINE RAMBO(N,ET,XM,P,WT)
***********************************************************************
*                       RAMBO                                         *
*    RA(NDOM)  M(OMENTA)  B(EAUTIFULLY)  O(RGANIZED)                  *
*                                                                     *
*    A DEMOCRATIC MULTI-PARTICLE PHASE SPACE GENERATOR                *
*    AUTHORS:  S.D. ELLIS,  R. KLEISS,  W.J. STIRLING                 *
*    THIS IS VERSION 1.0 -  WRITTEN BY R. KLEISS                      *
*    -- ADJUSTED BY HANS KUIJF, WEIGHTS ARE LOGARITHMIC (20-08-90)    *
*                                                                     *
*    N  = NUMBER OF PARTICLES                                         *
*    ET = TOTAL CENTRE-OF-MASS ENERGY                                 *
*    XM = PARTICLE MASSES ( DIM=NEXTERNAL-nincoming )                 *
*    P  = PARTICLE MOMENTA ( DIM=(4,NEXTERNAL-nincoming) )            *
*    WT = WEIGHT OF THE EVENT                                         *
***********************************************************************
      IMPLICIT REAL*8(A-H,O-Z)
      INCLUDE "nexternal.inc"
      DIMENSION XM(NEXTERNAL-NINCOMING),P(4,NEXTERNAL-NINCOMING)
      DIMENSION Q(4,NEXTERNAL-NINCOMING),Z(NEXTERNAL-NINCOMING),R(4),
     .   B(3),P2(NEXTERNAL-NINCOMING),XM2(NEXTERNAL-NINCOMING),
     .   E(NEXTERNAL-NINCOMING),V(NEXTERNAL-NINCOMING),IWARN(5)
      SAVE ACC,ITMAX,IBEGIN,IWARN
      DATA ACC/1.D-14/,ITMAX/6/,IBEGIN/0/,IWARN/5*0/
      SAVE TWOPI, PO2LOG, Z(2)
*
* INITIALIZATION STEP: FACTORIALS FOR THE PHASE SPACE WEIGHT
      IF(IBEGIN.NE.0) GOTO 103
      IBEGIN=1
      TWOPI=8.*DATAN(1.D0)
      PO2LOG=LOG(TWOPI/4.)
      Z(2)=PO2LOG
      DO 101 K=3,NEXTERNAL-NINCOMING
  101 Z(K)=Z(K-1)+PO2LOG-2.*LOG(DFLOAT(K-2))
      DO 102 K=3,NEXTERNAL-NINCOMING
  102 Z(K)=(Z(K)-LOG(DFLOAT(K-1)))
*
* CHECK ON THE NUMBER OF PARTICLES
  103 IF(N.GT.1.AND.N.LT.101) GOTO 104
      PRINT 1001,N
      STOP
*
* CHECK WHETHER TOTAL ENERGY IS SUFFICIENT; COUNT NONZERO MASSES
  104 XMT=0.
      NM=0
      DO 105 I=1,N
      IF(XM(I).NE.0.D0) NM=NM+1
  105 XMT=XMT+ABS(XM(I))
      IF(XMT.LE.ET) GOTO 201
      PRINT 1002,XMT,ET
      STOP
*
* THE PARAMETER VALUES ARE NOW ACCEPTED
*
* GENERATE N MASSLESS MOMENTA IN INFINITE PHASE SPACE
  201 DO 202 I=1,N
         r1=rn(1)
      C=2.*r1-1.
      S=SQRT(1.-C*C)
      F=TWOPI*RN(2)
      r1=rn(3)
      r2=rn(4)
      Q(4,I)=-LOG(r1*r2)
      Q(3,I)=Q(4,I)*C
      Q(2,I)=Q(4,I)*S*COS(F)
  202 Q(1,I)=Q(4,I)*S*SIN(F)
*
* CALCULATE THE PARAMETERS OF THE CONFORMAL TRANSFORMATION
      DO 203 I=1,4
  203 R(I)=0.
      DO 204 I=1,N
      DO 204 K=1,4
  204 R(K)=R(K)+Q(K,I)
      RMAS=SQRT(R(4)**2-R(3)**2-R(2)**2-R(1)**2)
      DO 205 K=1,3
  205 B(K)=-R(K)/RMAS
      G=R(4)/RMAS
      A=1./(1.+G)
      X=ET/RMAS
*
* TRANSFORM THE Q'S CONFORMALLY INTO THE P'S
      DO 207 I=1,N
      BQ=B(1)*Q(1,I)+B(2)*Q(2,I)+B(3)*Q(3,I)
      DO 206 K=1,3
  206 P(K,I)=X*(Q(K,I)+B(K)*(Q(4,I)+A*BQ))
  207 P(4,I)=X*(G*Q(4,I)+BQ)
*
* CALCULATE WEIGHT AND POSSIBLE WARNINGS
      WT=PO2LOG
      IF(N.NE.2) WT=(2.*N-4.)*LOG(ET)+Z(N)
      IF(WT.GE.-180.D0) GOTO 208
      IF(IWARN(1).LE.5) PRINT 1004,WT
      IWARN(1)=IWARN(1)+1
  208 IF(WT.LE. 174.D0) GOTO 209
      IF(IWARN(2).LE.5) PRINT 1005,WT
      IWARN(2)=IWARN(2)+1
*
* RETURN FOR WEIGHTED MASSLESS MOMENTA
  209 IF(NM.NE.0) GOTO 210
* RETURN LOG OF WEIGHT
      WT=WT
      RETURN
*
* MASSIVE PARTICLES: RESCALE THE MOMENTA BY A FACTOR X
  210 XMAX=SQRT(1.-(XMT/ET)**2)
      DO 301 I=1,N
      XM2(I)=XM(I)**2
  301 P2(I)=P(4,I)**2
      ITER=0
      X=XMAX
      ACCU=ET*ACC
  302 F0=-ET
      G0=0.
      X2=X*X
      DO 303 I=1,N
      E(I)=SQRT(XM2(I)+X2*P2(I))
      F0=F0+E(I)
  303 G0=G0+P2(I)/E(I)
      IF(ABS(F0).LE.ACCU) GOTO 305
      ITER=ITER+1
      IF(ITER.LE.ITMAX) GOTO 304
      PRINT 1006,ITMAX
      GOTO 305
  304 X=X-F0/(X*G0)
      GOTO 302
  305 DO 307 I=1,N
      V(I)=X*P(4,I)
      DO 306 K=1,3
  306 P(K,I)=X*P(K,I)
  307 P(4,I)=E(I)
*
* CALCULATE THE MASS-EFFECT WEIGHT FACTOR
      WT2=1.
      WT3=0.
      DO 308 I=1,N
      WT2=WT2*V(I)/E(I)
  308 WT3=WT3+V(I)**2/E(I)
      WTM=(2.*N-3.)*LOG(X)+LOG(WT2/WT3*ET)
*
* RETURN FOR  WEIGHTED MASSIVE MOMENTA
      WT=WT+WTM
      IF(WT.GE.-180.D0) GOTO 309
      IF(IWARN(3).LE.5) PRINT 1004,WT
      IWARN(3)=IWARN(3)+1
  309 IF(WT.LE. 174.D0) GOTO 310
      IF(IWARN(4).LE.5) PRINT 1005,WT
      IWARN(4)=IWARN(4)+1
* RETURN LOG OF WEIGHT
  310 WT=WT
      RETURN
*
 1001 FORMAT(' RAMBO FAILS: # OF PARTICLES =',I5,' IS NOT ALLOWED')
 1002 FORMAT(' RAMBO FAILS: TOTAL MASS =',D15.6,' IS NOT',
     . ' SMALLER THAN TOTAL ENERGY =',D15.6)
 1004 FORMAT(' RAMBO WARNS: WEIGHT = EXP(',F20.9,') MAY UNDERFLOW')
 1005 FORMAT(' RAMBO WARNS: WEIGHT = EXP(',F20.9,') MAY  OVERFLOW')
 1006 FORMAT(' RAMBO WARNS:',I3,' ITERATIONS DID NOT GIVE THE',
     . ' DESIRED ACCURACY =',D15.6)
      END

      FUNCTION RN(IDUMMY)
      REAL*8 RN,RAN
      SAVE INIT
      DATA INIT /1/
      IF (INIT.EQ.1) THEN
        INIT=0
        CALL RMARIN(1802,9373)
      END IF
*
  10  CALL RANMAR(RAN)
      IF (RAN.LT.1D-16) GOTO 10
      RN=RAN
*
      END

      SUBROUTINE RANMAR(RVEC)
*     -----------------
* Universal random number generator proposed by Marsaglia and Zaman
* in report FSU-SCRI-87-50
* In this version RVEC is a double precision variable.
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/ RASET1 / RANU(97),RANC,RANCD,RANCM
      COMMON/ RASET2 / IRANMR,JRANMR
      SAVE /RASET1/,/RASET2/
      UNI = RANU(IRANMR) - RANU(JRANMR)
      IF(UNI .LT. 0D0) UNI = UNI + 1D0
      RANU(IRANMR) = UNI
      IRANMR = IRANMR - 1
      JRANMR = JRANMR - 1
      IF(IRANMR .EQ. 0) IRANMR = 97
      IF(JRANMR .EQ. 0) JRANMR = 97
      RANC = RANC - RANCD
      IF(RANC .LT. 0D0) RANC = RANC + RANCM
      UNI = UNI - RANC
      IF(UNI .LT. 0D0) UNI = UNI + 1D0
      RVEC = UNI
      END

      SUBROUTINE RMARIN(IJ,KL)
*     -----------------
* Initializing routine for RANMAR, must be called before generating
* any pseudorandom numbers with RANMAR. The input values should be in
* the ranges 0<=ij<=31328 ; 0<=kl<=30081
      IMPLICIT REAL*8(A-H,O-Z)
      COMMON/ RASET1 / RANU(97),RANC,RANCD,RANCM
      COMMON/ RASET2 / IRANMR,JRANMR
      SAVE /RASET1/,/RASET2/
* This shows correspondence between the simplified input seeds IJ, KL
* and the original Marsaglia-Zaman seeds I,J,K,L.
* To get the standard values in the Marsaglia-Zaman paper (i=12,j=34
* k=56,l=78) put ij=1802, kl=9373
      I = MOD( IJ/177 , 177 ) + 2
      J = MOD( IJ     , 177 ) + 2
      K = MOD( KL/169 , 178 ) + 1
      L = MOD( KL     , 169 )
      DO 300 II = 1 , 97
        S =  0D0
        T = .5D0
        DO 200 JJ = 1 , 24
          M = MOD( MOD(I*J,179)*K , 179 )
          I = J
          J = K
          K = M
          L = MOD( 53*L+1 , 169 )
          IF(MOD(L*M,64) .GE. 32) S = S + T
          T = .5D0*T
  200   CONTINUE
        RANU(II) = S
  300 CONTINUE
      RANC  =   362436D0 / 16777216D0
      RANCD =  7654321D0 / 16777216D0
      RANCM = 16777213D0 / 16777216D0
      IRANMR = 97
      JRANMR = 33
      END


c=======================================================================
c
c     SGAMMA
c
c     Standard Gamma distribution generator G(a)
c
c-----------------------------------------------------------------------
c
c     Copyright (c) 2014 NumX
c     All rights reserved.
c
c     This software is the confidential and proprietary information
c     of NumX. You shall not disclose such Confidential
C     Information and shall use it only in accordance with the terms
c     of the licence agreement you entered into with NumX.
c
c     author: Yann Vernaz
c
c-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION sgamma(a)
c-----------------------------------------------------------------------
c
c     INPUT :
c      a : Gamma parameter (>= 1.0)                               double
c
c     Method - for details see:
c
c     AHRENS, J.H. AND DIETER, U.
c     GENERATING GAMMA VARIATES BY A
c     MODIFIED REJECTION TECHNIQUE.
c     COMM. ACM, 25,1 (JAN. 1982), 47 - 54.
c
c     STEP NUMBERS CORRESPOND TO ALGORITHM 'GD' IN THE ABOVE PAPER
c                                 (STRAIGHTFORWARD IMPLEMENTATION)
c
c     PARAMETER  0.0 < A < 1.0  !
c
c     AHRENS, J.H. AND DIETER, U.
c     COMPUTER METHODS FOR SAMPLING FROM GAMMA,
c     BETA, POISSON AND BINOMIAL DISTRIBUTIONS.
c     COMPUTING, 12 (1974), 223 - 246.
c
c     (ADAPTED IMPLEMENTATION OF ALGORITHM 'GS' IN THE ABOVE PAPER)
c
c     COEFFICIENTS Q(K) - FOR Q0 = SUM(Q(K)*A**(-K))
c     COEFFICIENTS A(K) - FOR Q = Q0+(T*T/2)*SUM(A(K)*V**K)
c     COEFFICIENTS E(K) - FOR EXP(Q)-1 = SUM(E(K)*Q**K)
c
c-----------------------------------------------------------------------
c
c     scalar arguments
      DOUBLE PRECISION a
c
c     local scalars
      DOUBLE PRECISION a1,a2,a3,a4,a5,a6,a7,aa,aaa,b,b0,c,d,e,e1,e2,e3,
     +     e4,e5,p,q,q0,
     +     q1,q2,q3,q4,q5,q6,q7,r,s,s2,si,sqrt32,t,u,v,w,x
c
c     external functions
      DOUBLE PRECISION ranf, sexpo, snorm
      EXTERNAL ranf, sexpo, snorm
c
c     intrinsic functions
      INTRINSIC abs, log, exp, sign, sqrt
c
c     save statement
      SAVE aa,aaa,s2,s,d,q0,b,si,c,q1,q2,q3,q4,q5,q6,q7,a1,a2,a3,a4,a5,
     +     a6,a7,e1,e2,e3,e4,e5,sqrt32
c
c     data statements
c     PREVIOUS A PRE-SET TO ZERO - AA IS A', AAA IS A"
c     SQRT32 IS THE SQUAREROOT OF 32 = 5.656854249492380
      DATA q1,q2,q3,q4,q5,q6,q7/.04166669,.02083148,.00801191,.00144121,
     +     -.00007388,.00024511,.00024240/
      DATA a1,a2,a3,a4,a5,a6,a7/.3333333,-.2500030,.2000062,-.1662921,
     +     .1423657,-.1367177,.1233795/
      DATA e1,e2,e3,e4,e5/1.,.4999897,.1668290,.0407753,.0102930/
      DATA aa/0.0/,aaa/0.0/,sqrt32/5.656854/
c
c     executable statements
      IF (a.EQ.aa) GO TO 10
      IF (a.LT.1.0) GO TO 130
c
c     STEP  1:  RECALCULATIONS OF S2,S,D IF A HAS CHANGED
      aa = a
      s2 = a - 0.5
      s = sqrt(s2)
      d = sqrt32 - 12.0*s
c
c     STEP  2:  T=STANDARD NORMAL DEVIATE,
c               X=(S,1/2)-NORMAL DEVIATE.
c               IMMEDIATE ACCEPTANCE (I)
   10 t = snorm()
      x = s + 0.5*t
      sgamma = x*x
      IF (t.GE.0.0) RETURN
c
c     STEP  3:  U= 0,1 -UNIFORM SAMPLE. SQUEEZE ACCEPTANCE (S)
      u = ranf()
      IF (d*u.LE.t*t*t) RETURN
c
c     STEP  4:  RECALCULATIONS OF Q0,B,SI,C IF NECESSARY
      IF (a.EQ.aaa) GO TO 40
      aaa = a
      r = 1.0/a
      q0 = ((((((q7*r+q6)*r+q5)*r+q4)*r+q3)*r+q2)*r+q1)*r
c
c               APPROXIMATION DEPENDING ON SIZE OF PARAMETER A
c               THE CONSTANTS IN THE EXPRESSIONS FOR B, SI AND
c               C WERE ESTABLISHED BY NUMERICAL EXPERIMENTS
      IF (a.LE.3.686) GO TO 30
      IF (a.LE.13.022) GO TO 20
c
c               CASE 3:  A .GT. 13.022
      b = 1.77
      si = .75
      c = .1515/s
      GO TO 40
c
c               CASE 2:  3.686 .LT. A .LE. 13.022
   20 b = 1.654 + .0076*s2
      si = 1.68/s + .275
      c = .062/s + .024
      GO TO 40
c
c               CASE 1:  A .LE. 3.686
   30 b = .463 + s + .178*s2
      si = 1.235
      c = .195/s - .079 + .16*s
c
c     STEP  5:  NO QUOTIENT TEST IF X NOT POSITIVE
   40 IF (x.LE.0.0) GO TO 70
c
c     STEP  6:  CALCULATION OF V AND QUOTIENT Q
      v = t/ (s+s)
      IF (abs(v).LE.0.25) GO TO 50
      q = q0 - s*t + 0.25*t*t + (s2+s2)*log(1.0+v)
      GO TO 60
c
   50 q = q0 + 0.5*t*t* ((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v
c
c     STEP  7:  QUOTIENT ACCEPTANCE (Q)
   60 IF (log(1.0-u).LE.q) RETURN
c
c     STEP  8:  E=STANDARD EXPONENTIAL DEVIATE
c               U= 0,1 -UNIFORM DEVIATE
c               T=(B,SI)-DOUBLE EXPONENTIAL (LAPLACE) SAMPLE
   70 e = sexpo()
      u = ranf()
      u = u + u - 1.0
      t = b + sign(si*e,u)
c
c     STEP  9:  REJECTION IF T .LT. TAU(1) = -.71874483771719
   80 IF (t.LT. (-.7187449)) GO TO 70
c
c     STEP 10:  CALCULATION OF V AND QUOTIENT Q
      v = t/ (s+s)
      IF (abs(v).LE.0.25) GO TO 90
      q = q0 - s*t + 0.25*t*t + (s2+s2)*log(1.0+v)
      GO TO 100
c
   90 q = q0 + 0.5*t*t* ((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v
c
c     STEP 11:  HAT ACCEPTANCE (H) (IF Q NOT POSITIVE GO TO STEP 8)
  100 IF (q.LE.0.0) GO TO 70
      IF (q.LE.0.5) GO TO 110
c
c     through line 125 to handle large Q case
      IF (q.LT.15.0) GO TO 105
c
c     Here Q is large enough that Q = log(exp(Q) - 1.0) (for DOUBLE PRECISION Q)
c     reformulate test at 120 in terms of one EXP, if not too big
c     87.49823 is close to the largest DOUBLE PRECISION which can be
c     exponentiated (87.49823 = log(1.0E38))
      IF ((q+e-0.5*t*t).GT.87.49823) GO TO 125
      IF (c*abs(u).GT.exp(q+e-0.5*t*t)) GO TO 70
      GO TO 125
c
 105  w = exp(q) - 1.0
      GO TO 120
c
  110 w = ((((e5*q+e4)*q+e3)*q+e2)*q+e1)*q
c
c               IF T IS REJECTED, SAMPLE AGAIN AT STEP 8
  120 IF (c*abs(u).GT.w*exp(e-0.5*t*t)) GO TO 70
 125  x = s + 0.5*t
      sgamma = x*x
      RETURN
c
c     ALTERNATE METHOD FOR PARAMETERS A BELOW 1  (.3678794=EXP(-1.))
c
c     changed B to B0 (which was added to declarations for this)
c     in 130 to END to fix rare and subtle bug.
c     Line: '130 aa = 0.0' was removed (unnecessary, wasteful).
c     Reasons: the state of AA only serves to tell the A .GE. 1.0
c     case if certain A-dependant constants need to be recalculated.
c     The A .LT. 1.0 case (here) no longer changes any of these, and
c     the recalculation of B (which used to change with an
c     A .LT. 1.0 call) is governed by the state of AAA anyway.
 130  b0 = 1.0 + .3678794*a
  140 p = b0*ranf()
      IF (p.GE.1.0) GO TO 150
      sgamma = exp(log(p)/a)
      IF (sexpo().LT.sgamma) GO TO 140
      RETURN
c
  150 sgamma = -log((b0-p)/a)
      IF (sexpo().LT. (1.0-a)*log(sgamma)) GO TO 140
      RETURN
      END


subroutine vortex_line(circ,vlen,thetax,thetay,thetaz,xloc,yloc,zloc,wff)
	use params
	implicit none
	integer :: i,j,k,circ,BN
	double precision :: vlen,a,b,c,thetax,thetay,thetaz,phi,xloc,yloc,zloc
	complex*16, dimension(:,:,:), allocatable :: wfv

	complex*16, dimension(-NX/2:NX/2,-NY/2:NY/2,-NZ/2:NZ/2) :: wff
	double precision, dimension(1:3,1:3) :: rx,ry,rz
	double precision, dimension(1:3) :: xyz,abc

	BN = ceiling(sqrt(DBLE(NX*NX + NY*NY + NZ*NZ)))
	ALLOCATE(wfv(-BN:BN,-BN:BN,-BN:BN))

	do i = -BN, BN
		do j = -BN, BN
			do k = -BN, BN
				xyz(1) = (i*DSPACE)
				xyz(2) = (j*DSPACE)
				xyz(3) = (k*DSPACE)
				if(abs(xyz(3)) < vlen/2.0d0) then
					wfv(i,j,k) = exp(circ*EYE*(ATAN2(xyz(2),xyz(1))))
				else
					wfv(i,j,k) = 1.0d0
				end if
			end do
		end do
	end do

	rx(1,1) = 1.0d0
	rx(2,1) = 0.0d0
	rx(3,1) = 0.0d0
	rx(1,2) = 0.0d0
	rx(2,2) = cos(thetax)
	rx(3,2) = sin(thetax)
	rx(1,3) = 0.0d0
	rx(2,3) = -sin(thetax)
	rx(3,3) = cos(thetax)

	ry(1,1) = cos(thetay)
	ry(2,1) = 0.0d0
	ry(3,1) = -sin(thetay)
	ry(1,2) = 0.0d0
	ry(2,2) = 1.0d0
	ry(3,2) = 0.0d0
	ry(1,3) = sin(thetay)
	ry(2,3) = 0.0d0
	ry(3,3) = cos(thetay)

	rz(1,1) = cos(thetaz)
	rz(2,1) = sin(thetaz)
	rz(3,1) = 0.0d0
	rz(1,2) = -sin(thetaz)
	rz(2,2) = cos(thetaz)
	rz(3,2) = 0.0d0
	rz(1,3) = 0.0d0
	rz(2,3) = 0.0d0
	rz(3,3) = 1.0d0
	!rotate and translate to make final wavefunction
	do i = -NX/2, NX/2
		do j = -NY/2, NY/2
			do k = -NZ/2, NZ/2
				xyz(1) = (i*DSPACE)-xloc
				xyz(2) = (j*DSPACE)-yloc
				xyz(3) = (k*DSPACE)-zloc
				!rotate
				abc = MATMUL(rz,MATMUL(ry,MATMUL(rx,xyz)))
				!translate
				wff(i,j,k) = wff(i,j,k)*wfv(nint(abc(1)/DSPACE),nint(abc(2)/DSPACE),nint(abc(3)/DSPACE))

			end do
		end do
	end do

end subroutine


      subroutine run_ii(j,i1,i2,DetGr,Xtwiddle0,Gtwiddle,Shat3,N0)
      implicit none
C---  Fixes Dii using Eq. 5.45
C     knowing D00i with correction of order Delta Diii
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,j,i1,i2,n
      double precision DetGr,Xtwiddle0(3),Gtwiddle(3,3)
      double complex Shat3(3,z2max,-2:0),Shat3s(3,z2max,-2:0)

      do ep=-2,0
      do n=1,3
      Shat3s(n,z2(i1,i2),ep)=Shat3(n,z2(i1,i2),ep)
     .   -2d0*(delta(n,i1)*Dv(N0+dzzi(i2),ep)
     .        +delta(n,i2)*Dv(N0+dzzi(i1),ep))
      enddo

      Dv(dii(z2(i1,i2))+N0,ep)=-(
     . +Gtwiddle(j,1)*Shat3s(1,z2(i1,i2),ep)
     . +Gtwiddle(j,2)*Shat3s(2,z2(i1,i2),ep)
     . +Gtwiddle(j,3)*Shat3s(3,z2(i1,i2),ep)
     . -DetGr*Dv(diii(z3(j,i1,i2))+N0,ep))/Xtwiddle0(j)

      enddo

      return
      end


      subroutine nut_denit(k,j,cdg,wdn,void)
!!    this subroutine computes denitrification

      use basin_module
      use organic_mineral_mass_module
      use soil_module

      implicit none

	  integer :: k          !none          |counter
      integer :: j          !none          |HRU number
 	  real :: cdg           !none          |soil temperature factor
      real ::wdn            !kg N/ha       |amount of nitrogen lost from nitrate pool in
                            !              |layer due to denitrification
      real :: void          !              |
      real :: vof           !              |

      wdn = 0.
	  vof = 1. / (1. + (void/0.04)**5)
	  wdn =  soil1(j)%mn(k)%no3 * (1. - Exp(-bsn_prm%cdn * cdg * vof *          &
              soil1(j)%tot(k)%c))
	  soil1(j)%mn(k)%no3 = soil1(j)%mn(k)%no3 - wdn

	  return
	  end subroutine nut_denit


module sysconfig
! module for config of cell cluster
use parameters

!!!  SIMULATION PARAMETERS  [start] !!!
integer,  parameter ::   geoTotal = 1      ! total number of cluster geometries to iterate through
integer,  parameter ::   runTotal = 10     ! total number of runs
integer,  parameter ::  cellTotal = 4      ! total number of cells in system
integer,  parameter :: prtclTotal = 500   ! total possible number of particles in system
!!!  SIMULATION PARAMETERS  [end]   !!!

contains

    subroutine getProbTimeScale( ntItl, dtReal, p, q)
        implicit none
        real(b8), intent(out) :: dtReal, p, q
        integer,  intent(out) :: ntItl
        ! calculate time step in real units
        dtReal = min( bReal*bReal / dReal / 6.0_b8, 1.0_b8 / kReal)
        ! calculate probailities of diffusion and production events
        p = 6.0_b8 * dReal * dtReal / bReal**2
        q = kReal * dtReal
        ! calculate the number of timesteps needed for equilibration
        ntItl = 10 * ceiling( max( lReal**2 / (dReal * dtReal), (kReal * dtReal)**(-1)) )
    end subroutine getProbTimeScale

    subroutine getSysLengthScales( dr, rsim)
        implicit none
        real(b8) , intent(out) :: dr(3), rsim(3,2)

        dr(:) = bReal
        rsim(:,1) = 0.0_b8
        rsim(1,2) =  lReal
        rsim(2,2) = syReal
        rsim(3,2) = szReal
    end subroutine getSysLengthScales

    ! initialize 3D cluster of cells using nearest-neighbor (NN) method
    subroutine itl3DClusterNN( cellArray, rsim)
        implicit none
        real(b8), intent(out) :: cellArray(:,:,:)
        real(b8), intent(in)  :: rsim(:,:)
        real(b8), allocatable :: dList(:), dTest(:)
        integer,  allocatable :: nnList(:,:), nnTest(:,:)
        real(b8) :: a, nnd, nndmax, x0, y0, z0
        integer :: center( cellTotal, 3), test(3)
        integer :: i, itest, inn, j, k, k1, k2, k3, kmax, n, centerCheck

        allocate(  dList(900))
        allocate(  dTest(900))
        allocate( nnList(900,3))
        allocate( nnTest(900,3))
        cellArray(:,:,:) = 0.0_b8
        ! set center and cellArray for cell 1
        x0 = (rsim(1,2) - rsim(1,1)) / 2.0_b8
        y0 = (rsim(2,2) - rsim(2,1)) / 2.0_b8
        z0 = (rsim(3,2) - rsim(3,1)) / 2.0_b8
        do i = 1, 3
            cellArray(1,i,1) = (rsim(i,2) - rsim(i,1)) / 2.0_b8 - rReal
            cellArray(1,i,2) = (rsim(i,2) - rsim(i,1)) / 2.0_b8 + rReal
        enddo
        center(:,:) = 0
        ! write(*,*) center(1,1:3)
        if ( cellTotal == 1 ) then
            return
        end if
        n = 2
        kmax = 1
        dList = 0.0_b8
        nnList = 0
        do while ( n <= cellTotal )
            ! check for free NN sites
            ! write(*,*) '  kmax =', kmax
            k = 1
            test = 0
            nnList = 0
            dList  = 0.0_b8
            do k1 = kmax, -kmax, -1
                do k2 = kmax, -kmax, -1
                    do k3 = kmax, -kmax, -1
                        do j = 1, n-1
                            centerCheck = 0
                            test(1:3) = [center(1,1) + k1, center(1,2) + k2, center(1,3) + k3]
                            if ( center(j,1) == test(1) .AND. center(j,2) == test(2) .AND. center(j,3) == test(3) ) then
                                centerCheck = 1
                                exit
                            endif
                        enddo
                        if ( centerCheck == 0 ) then
                            nnList(k,:) = test
                            dList(k) = 0.0
                            do j = 1, 3
                                dList(k) = dList(k) + float(nnList(k,j)-center(1,j))**2
                            enddo
                            dList(k) = sqrt( dList(k) )
                            k = k + 1
                        endif
                    enddo
                enddo
            enddo
            inn = k - 1
            nndmax = float(ceiling(minval( dList(1:inn)) + 0.00001))
            ! write(*,*)
            ! do i = 1, inn
            !     write(*,*) i, nnList(i,:), dList(i)
            ! enddo
            ! write(*,*)
            do while ( inn > 0 .AND. n <= cellTotal )
                nnd = minval( dList(1:inn))
                if ( nnd == maxval( dList(1:inn)) .OR. nnd >= nndmax ) then
                    exit
                end if
                ! write(*,*) 'nnd =', nnd, '  inn =', inn
                 dTest =  dList
                nnTest = nnList
                do i = 1, inn
                    if ( dList(i) == nnd .AND. n <= cellTotal) then
                        center(n,1:3) = nnList(i,1:3)
                        n = n + 1
                        ! remove nnList and dList entries that have been added to center
                         dTest(i)   = 0.0
                        nnTest(i,:) = [ 0, 0, 0]
                    end if
                enddo
                j = inn
                do i = inn, 1, -1
                    if ( dTest(i) == 0.0 ) then
                        if ( i /= inn ) then
                             dList(i:inn-1)   =  dList(i+1:inn)
                            nnList(i:inn-1,:) = nnList(i+1:inn,:)
                        end if
                        j = j - 1
                    end if
                enddo
                inn = j
                ! write(*,*)
                ! do i = 1, inn
                !     write(*,*) i, nnList(i,:), dList(i)
                ! enddo
                ! write(*,*)
            enddo
            kmax = kmax + 1
        enddo
        itest = cellTotal
        do i = 2, itest
            cellArray(i,1,1:2) = [ x0 + (2.0*float(center(i,1))-1.0) * rReal, x0 + (2.0*float(center(i,1))+1.0) * rReal]
            cellArray(i,2,1:2) = [ y0 + (2.0*float(center(i,2))-1.0) * rReal, y0 + (2.0*float(center(i,2))+1.0) * rReal]
            cellArray(i,3,1:2) = [ z0 + (2.0*float(center(i,3))-1.0) * rReal, z0 + (2.0*float(center(i,3))+1.0) * rReal]
        enddo
        if ( minval(cellArray(1:cellTotal,1:3,1)) < 0.0 .OR. maxval(cellArray(1:cellTotal,1:3,2)) > rsim(1,2) ) then
            write(*,*) '           INITIALIZATION ERROR             '
            write(*,*) 'ERROR: SYSTEM SIZE TOO SMALL FOR CELL CLUSTER'
        end if

        deallocate( dList)
        deallocate( dTest)
        deallocate(nnList)
        deallocate(nnTest)
    end subroutine itl3DClusterNN

    ! initialize 2D cluster of cells using nearest-neighbor (NN) method
    subroutine itl2DClusterNN( cellArray, rsim)
        implicit none
        real(b8), intent(out) :: cellArray(:,:,:)
        real(b8), intent(in)  :: rsim(:,:)
        real(b8), allocatable :: dList(:), dTest(:)
        integer,  allocatable :: nnList(:,:)
        real(b8) :: a, nnd, nndmax, x0, y0
        integer :: center( cellTotal, 3), test(2)
        integer :: i, itest, inn, j, k, k1, k2, kmax, n, centerCheck

        allocate(  dList(200))
        allocate(  dTest(200))
        allocate( nnList(200,3))
        cellArray(:,:,:) = 0.0_b8
        ! set center and cellArray for cell 1
        x0 = (rsim(1,2) - rsim(1,1)) / 2.0_b8
        y0 = (rsim(2,2) - rsim(2,1)) / 2.0_b8
        cellArray(1,3,1) = ((rsim(3,2) - rsim(3,1)) / 2.0_b8) - (hReal / 2.0_b8)
        cellArray(1,3,2) = ((rsim(3,2) - rsim(3,1)) / 2.0_b8) + (hReal / 2.0_b8)
        do i = 1, 2
            cellArray(1,i,1) = (rsim(i,2) - rsim(i,1)) / 2.0_b8 - rReal
            cellArray(1,i,2) = (rsim(i,2) - rsim(i,1)) / 2.0_b8 + rReal
        enddo
        center(:,:) = 0
        ! write(*,*) center(1,1:2)
        if ( cellTotal == 1 ) then
            return
        end if
        n = 2
        kmax = 1
        dList = 0.0_b8
        nnList = 0
        do while ( n <= cellTotal )
            ! check for free NN sites
            ! write(*,*) '  kmax =', kmax
            k = 1
            test = 0
            nnList = 0
            dList  = 0.0_b8
            do k1 = kmax, -kmax, -1
                do k2 = kmax, -kmax, -1
                    do j = 1, n-1
                        centerCheck = 0
                        test = [center(1,1) + k1, center(1,2) + k2]
                        if ( center(j,1) == test(1) .AND. center(j,2) == test(2) ) then
                            centerCheck = 1
                            exit
                        end if
                    enddo
                    if ( centerCheck == 0 ) then
                        nnList(k,:) = test
                        dList(k) = sqrt( float(nnList(k,1)-center(1,1))**2 + float(nnList(k,2)-center(1,2))**2)
                        k = k + 1
                    end if
                enddo
            enddo
            inn = k - 1
            nndmax = float(ceiling(minval( dList(1:inn)) + 0.00001))
            do while ( inn > 0 .AND. n <= cellTotal )
                nnd = minval( dList(1:inn))
                if ( nnd == maxval( dList(1:inn)) .OR. nnd >= nndmax ) then
                    exit
                end if
                ! write(*,*) 'nnd =', nnd, '  inn =', inn
                dTest =  dList
                do i = 1, inn
                    if ( dList(i) == nnd .AND. n <= cellTotal) then
                        center(n,:) = nnList(i,:)
                        n = n + 1
                        ! remove nnList and dList entries that have been added to center
                        dTest(i)   = 0.0
                    end if
                enddo
                j = inn
                do i = inn, 1, -1
                    if ( dTest(i) == 0.0 ) then
                        if ( i /= inn ) then
                             dList(i:inn-1)   =  dList(i+1:inn)
                            nnList(i:inn-1,:) = nnList(i+1:inn,:)
                        end if
                        j = j - 1
                    end if
                enddo
                inn = j
            enddo
            kmax = kmax + 1
        enddo
        itest = cellTotal
        do i = 2, itest
            cellArray(i,1,1:2) = [ x0 + (2.0*float(center(i,1))-1.0) * rReal, x0 + (2.0*float(center(i,1))+1.0) * rReal]
            cellArray(i,2,1:2) = [ y0 + (2.0*float(center(i,2))-1.0) * rReal, y0 + (2.0*float(center(i,2))+1.0) * rReal]
            cellArray(i,3,1:2) = cellArray(1,3,1:2)
        enddo
        if ( minval(cellArray(1:cellTotal,1:3,1)) < 0.0 .OR. maxval(cellArray(1:cellTotal,1:3,2)) > rsim(1,2) ) then
            write(*,*) '           INITIALIZATION ERROR             '
            write(*,*) 'ERROR: SYSTEM SIZE TOO SMALL FOR CELL CLUSTER'
        end if

        deallocate(  dList)
        deallocate(  dTest)
        deallocate( nnList)
    end subroutine itl2DClusterNN

    ! initialize positions of cells to form a cluster
    ! cells are randomly placed along all possible sides of the cluster
    subroutine itl2DRandom( cellTotal, cellArray, rsim)
        implicit none
        integer,  intent(in)  :: cellTotal
        real(b8), intent(out) :: cellArray(:,:,:)
        real(b8), intent(in)  :: rsim(:,:)
        real(b8), allocatable :: center(:,:), dr(:,:), test(:)
        real(b8) :: r
        integer :: cellCheck, i, ii, j, k, n

        allocate( dr(4,2) )
        allocate( test(2) )
        allocate( center(cellTotal,2) )
        center(:,:)      = 0.0_b8
        cellArray(:,:,:) = 0.0_b8
        ! set dr
        dr(:,:) = 0.0_b8
        do i = 1, 2
            dr(i,i) = 2.0 * rReal
        enddo
        do i = 3, 4
            dr(i,i-2) = -2.0 * rReal
        enddo
        ! set center and cellArray for cell 1
        do i = 1, 2
            center(1,i) = (rsim(i,2) - rsim(i,1)) / 2.0_b8
        enddo
        do i = 1, 2
            cellArray(1,i,1) = center(1,i) - rReal
            cellArray(1,i,2) = center(1,i) + rReal
        enddo
        do i = 1, cellTotal
            cellArray(i,3,1) = ((rsim(3,2) - rsim(3,1)) / 2.0_b8) - (hReal / 2.0_b8)
            cellArray(i,3,2) = ((rsim(3,2) - rsim(3,1)) / 2.0_b8) + (hReal / 2.0_b8)
        enddo
        if ( cellTotal == 1 ) then
            return
        elseif ( cellTotal == 2 ) then
            center(2,1) = center(1,1) + (2.0 * rReal)
            center(2,2) = center(1,2)
            do i = 1, 2
                cellArray(2,i,1) = center(2,i) - rReal
                cellArray(2,i,2) = center(2,i) + rReal
            enddo
            return
        end if

        ! set center and cellArray for cells 2 to cellTotal
        n = 1
        i = 2
        do while ( i <= cellTotal .AND. n <= cellTotal )
            call random_number(r)
            j = 1 + floor( r * 4.0 )
            do k = 1, 4
                ! set test location for cell center i
                test(1) = center(n,1) + dr(j,1)
                test(2) = center(n,2) + dr(j,2)
                cellCheck = 0
                do ii = 1, i-1
                    ! check that no other cell center occupy test location
                    if ( center(ii,1) == test(1) .AND. center(ii,2) == test(2) ) then
                        cellCheck = 1
                    end if
                enddo
                if ( cellCheck == 0 ) then
                    center(i,:) = test
                    do ii = 1, 2
                        cellArray(i,ii,1) = test(ii) - rReal
                        cellArray(i,ii,2) = test(ii) + rReal
                    enddo
                    i = i + 1
                end if
                if ( i > cellTotal ) then
                    exit
                else
                    j = j + 1
                    if( j > 4 )then
                        j = 1
                    endif
                endif
            enddo
            n = n + 1
        enddo
        if ( minval(cellArray(1:cellTotal,1:3,1)) < 0.0 .OR. maxval(cellArray(1:cellTotal,1:3,2)) > rsim(1,2) ) then
            write(*,*) '           INITIALIZATION ERROR             '
            write(*,*) 'ERROR: SYSTEM SIZE TOO SMALL FOR CELL CLUSTER'
        end if
        deallocate( dr )
        deallocate( test )
        deallocate( center )
    end subroutine itl2DRandom

    ! initialize positions of cells to form a cluster
    ! cells are randomly placed along all possible sides of the cluster
    subroutine itl3DRandom( cellTotal, cellArray, rsim)
        implicit none
        integer,  intent(in)  :: cellTotal
        real(b8), intent(out) :: cellArray(:,:,:)
        real(b8), intent(in)  :: rsim(:,:)
        real(b8), allocatable :: center(:,:), dr(:,:), test(:)
        real(b8) :: r
        integer :: cellCheck, i, ii, j, k, n

        allocate( dr(6,3) )
        allocate( test(3) )
        allocate( center(cellTotal,3) )
        center(:,:)      = 0.0_b8
        cellArray(:,:,:) = 0.0_b8
        ! set dr
        dr(:,:) = 0.0_b8
        do i = 1, 3
            dr(i,i) = 2.0 * rReal
        enddo
        do i = 4, 6
            dr(i,i-3) = -2.0 * rReal
        enddo
        ! set center and cellArray for cell 1
        do i = 1, 3
            center(1,i) = (rsim(i,2) - rsim(i,1)) / 2.0_b8
        enddo
        do i = 1, 3
            cellArray(1,i,1) = center(1,i) - rReal
            cellArray(1,i,2) = center(1,i) + rReal
        enddo

        if ( cellTotal == 1 ) then
            return
        elseif ( cellTotal == 2 ) then
            center(2,1) = center(1,1) + (2.0 * rReal)
            center(2,2:3) = center(1,2:3)
            do i = 1, 3
                cellArray(2,i,1) = center(2,i) - rReal
                cellArray(2,i,2) = center(2,i) + rReal
            enddo
            return
        end if

        ! set center and cellArray for cells 2 to cellTotal
        n = 1
        i = 2
        do while ( i <= cellTotal .AND. n <= cellTotal )
            call random_number(r)
            j = 1 + floor( r * 6.0 )
            do k = 1, 6
                ! set test location for cell center i
                test(1) = center(n,1) + dr(j,1)
                test(2) = center(n,2) + dr(j,2)
                test(3) = center(n,3) + dr(j,3)
                cellCheck = 0
                do ii = 1, i-1
                    ! check that no other cell center occupy test location
                    if ( center(ii,1) == test(1) .AND. center(ii,2) == test(2) .AND. center(ii,3) == test(3) ) then
                        cellCheck = 1
                    end if
                enddo
                if ( cellCheck == 0 ) then
                    center(i,:) = test
                    do ii = 1, 3
                        cellArray(i,ii,1) = test(ii) - rReal
                        cellArray(i,ii,2) = test(ii) + rReal
                    enddo
                    i = i + 1
                end if
                if ( i > cellTotal ) then
                    exit
                else
                    j = j + 1
                    if( j > 6 )then
                        j = 1
                    endif
                endif
            enddo
            n = n + 1
        enddo
        if ( minval(cellArray(1:cellTotal,1:3,1)) < 0.0 .OR. maxval(cellArray(1:cellTotal,1:3,2)) > rsim(1,2) ) then
            write(*,*) '           INITIALIZATION ERROR             '
            write(*,*) 'ERROR: SYSTEM SIZE TOO SMALL FOR CELL CLUSTER'
        end if
        deallocate( dr )
        deallocate( test )
        deallocate( center )
    end subroutine itl3DRandom

    ! initialize cells into 1D chain along gradient direction
    subroutine itl1DChain( cellArray, rsim)
        implicit none
        real(b8), intent(out) :: cellArray(:,:,:)
        real(b8), intent(in)  :: rsim(:,:)
        real(b8) :: r0, r1
        integer :: i, j, k, n

        ! calculate start and end points of chain
        r0 = lReal/2.0_b8 - rReal*float(cellTotal)
        r1 = lReal/2.0_b8 + rReal*float(cellTotal)

        do i = 1, cellTotal
            cellArray(i,1,1) = r0 + rReal*2.0_b8*float(i-1)
            cellArray(i,1,2) = r0 + rReal*2.0_b8*float(i)
            do j = 2, 3
                cellArray(i,j,1) = (rsim(j,2) - rsim(j,1)) / 2.0_b8 - rReal
                cellArray(i,j,2) = (rsim(j,2) - rsim(j,1)) / 2.0_b8 + rReal
            enddo
        enddo
        if ( minval(cellArray(1:cellTotal,1:3,1)) < 0.0 .OR. maxval(cellArray(1:cellTotal,1:3,2)) > rsim(1,2) ) then
            write(*,*) '           INITIALIZATION ERROR             '
            write(*,*) 'ERROR: SYSTEM SIZE TOO SMALL FOR CELL CLUSTER'
        end if
    end subroutine itl1DChain

    ! make a list of cells which are on the perimeter
    ! edgeList(i) = 0 means that cell i is not an edge cell
    ! edgeList(i) = 1 means that cell i is an edge cell
    subroutine clusterEdgeList( cellTotal, cellArray, rsim, edgeList)
        implicit none
        integer,  intent(in)  :: cellTotal
        integer,  intent(out) :: edgeList(:)
        real(b8), intent(in)  :: cellArray(:,:,:), rsim(:,:)
        real(b8), allocatable :: center(:,:), dr(:,:)
        real(b8) :: dcell
        integer  :: i, j, k, n1, n2, check

        allocate( dr(6,3) )
        allocate( center(cellTotal,3) )
        ! set dr
        dr(:,:) = 0.0_b8
        do i = 1, 3
            dr(i,i) = 2.0 * rReal
        enddo
        do i = 4, 6
            dr(i,i-3) = -2.0 * rReal
        enddo
        ! set cell center from cellArray
        center(:,:)      = 0.0_b8
        do i = 1, cellTotal
            do j = 1, 3
                center(i,j) = cellArray(i,j,1) + (cellArray(i,j,2) - cellArray(i,j,1)) / 2.0_b8
            enddo
        enddo
        edgeList(:) = 1
        do n1 = 1, cellTotal
            check = 0
            do n2 = 1, cellTotal
                if ( n1 == n2 ) then
                    cycle
                end if
                dcell = 0.0_b8
                do j = 1, 3
                    dcell = dcell + (center(n1,j) - center(n2,j))**2
                enddo
                dcell = dsqrt(dcell)
                if ( dcell >= 2.0*rReal-0.000001 .AND. dcell <= 2.0*rReal+0.000001 ) then
                    check = check + 1
                end if
                if ( check > 5 ) then
                    edgeList(n1) = 0
                    exit
                end if
            enddo
        enddo
        deallocate( dr )
        deallocate( center )
    end subroutine clusterEdgeList

    ! make a list of cells which are on the perimeter of 2D cluster
    subroutine EdgeList2D( cellArray, rsim, edgeList)
        implicit none
        integer,  intent(out) :: edgeList(:)
        real(b8), intent(in)  :: cellArray(:,:,:), rsim(:,:)
        real(b8), allocatable :: center(:,:), dr(:,:)
        real(b8) :: dcell
        integer  :: i, j, k, n1, n2, check

        allocate( dr(4,2) )
        allocate( center(cellTotal,2) )
        ! set dr
        dr(:,:) = 0.0_b8
        do i = 1, 2
            dr(i,i) = 2.0 * rReal
        enddo
        do i = 3, 4
            dr(i,i-2) = -2.0 * rReal
        enddo
        ! set cell center from cellArray
        center(:,:)      = 0.0_b8
        do i = 1, cellTotal
            do j = 1, 2
                center(i,j) = cellArray(i,j,1) + (cellArray(i,j,2) - cellArray(i,j,1)) / 2.0_b8
            enddo
        enddo
        edgeList(:) = 1
        do n1 = 1, cellTotal
            check = 0
            do n2 = 1, cellTotal
                if ( n1 == n2 ) then
                    cycle
                end if
                dcell = 0.0_b8
                do j = 1, 2
                    dcell = dcell + (center(n1,j) - center(n2,j))**2
                enddo
                dcell = dsqrt(dcell)
                if ( dcell >= 2.0*rReal-0.000001 .AND. dcell <= 2.0*rReal+0.000001 ) then
                    check = check + 1
                end if
                if ( check > 3 ) then
                    edgeList(n1) = 0
                    exit
                end if
            enddo
        enddo
        deallocate( dr )
        deallocate( center )
    end subroutine EdgeList2D

    ! make a list of cells which on the ends of a 1D chain
    subroutine EdgeList1D( cellArray, edgeList)
        implicit none
        integer,  intent(out) :: edgeList(:)
        real(b8), intent(in)  :: cellArray(:,:,:)
        real(b8) :: center(cellTotal)
        real(b8) :: dcell
        integer  :: i, n1, n2, check

        ! set cell center from cellArray
        center(:) = 0.0_b8
        do i = 1, cellTotal
            center(i) = cellArray(i,1,1) + (cellArray(i,1,2) - cellArray(i,1,1)) / 2.0_b8
        enddo
        edgeList(:) = 1
        do n1 = 1, cellTotal
            check = 0
            do n2 = 1, cellTotal
                if ( n1 == n2 ) then
                    cycle
                end if
                dcell = abs(center(n1) - center(n2))
                if ( dcell >= 2.0*rReal-0.000001 .AND. dcell <= 2.0*rReal+0.000001 ) then
                    check = check + 1
                end if
                if ( check > 1 ) then
                    edgeList(n1) = 0
                    exit
                end if
            enddo
        enddo
    end subroutine EdgeList1D

    ! calculate center of mass of cell cluster, neccasary for EC polarization
    subroutine clusterCenter( cellArray, clstrCOM)
        implicit none
        real(b8), intent(in)  :: cellArray(:,:,:)
        real(b8), intent(out) :: clstrCOM(3)
        integer :: i, j
        clstrCOM = 0.0_b8
        do i = 1, cellTotal
            do j = 1, 3
                clstrCOM(j) = clstrCOM(j) + cellArray(i,j,1) + (cellArray(i,j,2) - cellArray(i,j,1)) / (2.0_b8)
            enddo
        enddo
        clstrCOM(:) = clstrCOM(:) / float(cellTotal)
    end subroutine clusterCenter

    ! read in cell locations from file and copy them to cellArray
    subroutine readCellLocation( cellArray)
        implicit none
        real(b8), intent(out) :: cellArray(:,:,:)
        integer  :: i, j, k
        open( unit=11, file='cellLocation.dat', status="old", action="read")

        cellArray = 0.0_b8
        do i = 1, cellTotal
            read( 11, *) j, k, cellArray(i,1,2), cellArray(i,1,1)
            read( 11, *) j, k, cellArray(i,2,2), cellArray(i,2,1)
            read( 11, *) j, k, cellArray(i,3,2), cellArray(i,3,1)
            ! write(*,*) 'i', i, cellArray(i,:,:)
        enddo
        close(11)
    end subroutine readCellLocation

    subroutine wrtCellLocation( cellArray)
        implicit none
        real(b8), intent(in) :: cellArray(:,:,:)
        real(b8) :: center
        integer  :: i, j

        do i = 1, cellTotal
            do j = 1, 3
                center = cellArray(i,j,1) + (cellArray(i,j,2) - cellArray(i,j,1)) / (2.0_b8)
                write(210,'(I4)', advance='no') i
                write(210,'(I4)', advance='no') j
                write(210,'(F7.3,F7.3)', advance='no') cellArray(i,j,2), cellArray(i,j,1)
                write(210,'(F7.3)', advance='no') center
                write(210,*) ''
            enddo
        enddo
    end subroutine wrtCellLocation

    ! output cell locations and system size. Output file fort.199
    subroutine wrtOutClusterSys( cellTotal, cellArray, rsim)
        implicit none
        integer,  intent(in) :: cellTotal
        real(b8), intent(in) :: cellArray(:,:,:), rsim(:,:)
        integer :: i
        write(199,*)
        do i = 1, cellTotal
            write(199,*) 'cell', i
            write(199,*) '   x', cellArray(i,1,:), cellArray(i,1,2)-cellArray(i,1,1)
            write(199,*) '   y', cellArray(i,2,:), cellArray(i,2,2)-cellArray(i,2,1)
            write(199,*) '   z', cellArray(i,3,:), cellArray(i,3,2)-cellArray(i,3,1)
        enddo
        write(199,*)
    end subroutine wrtOutClusterSys

    ! calculate the centroid of each cell
    subroutine getCellCenter( cellArray, cellCenter)
        implicit none
        real(b8), intent(in)  :: cellArray(:,:,:)
        real(b8), intent(out) :: cellCenter(:,:)
        integer :: i, j

        cellCenter = 0.0_b8
        do i = 1, cellTotal
            do j = 1, 3
                cellCenter(i,j) = (cellArray(i,j,1) + cellArray(i,j,2)) / 2.0_b8
            enddo
        enddo
    end subroutine getCellCenter

end module


      SUBROUTINE TG01PD( DICO, STDOM, JOBAE, COMPQ, COMPZ, N, M, P,
     $                   NLOW, NSUP, ALPHA, A, LDA, E, LDE, B, LDB,
     $                   C, LDC, Q, LDQ, Z, LDZ, NDIM, ALPHAR, ALPHAI,
     $                   BETA, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute orthogonal transformation matrices Q and Z which
C     reduce the regular pole pencil A-lambda*E of the descriptor system
C     (A-lambda*E,B,C) to the generalized real Schur form with ordered
C     generalized eigenvalues. The pair (A,E) is reduced to the form
C
C                ( *  *  *  * )             ( *  *  *  * )
C                (            )             (            )
C                ( 0  A1 *  * )             ( 0  E1 *  * )
C       Q'*A*Z = (            ) ,  Q'*E*Z = (            ) ,
C                ( 0  0  A2 * )             ( 0  0  E2 * )
C                (            )             (            )
C                ( 0  0  0  * )             ( 0  0  0  * )
C
C     where the subpencil A1-lambda*E1 contains the eigenvalues which
C     belong to a suitably defined domain of interest and the subpencil
C     A2-lambda*E2 contains the eigenvalues which are outside of the
C     domain of interest.
C     If JOBAE = 'S', the pair (A,E) is assumed to be already in a
C     generalized real Schur form and the reduction is performed only
C     on the subpencil A12 - lambda*E12 defined by rows and columns
C     NLOW to NSUP of A - lambda*E.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the descriptor system as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     STDOM   CHARACTER*1
C             Specifies whether the domain of interest is of stability
C             type (left part of complex plane or inside of a circle)
C             or of instability type (right part of complex plane or
C             outside of a circle) as follows:
C             = 'S':  stability type domain;
C             = 'U':  instability type domain.
C
C     JOBAE   CHARACTER*1
C             Specifies the shape of the matrix pair (A,E) on entry
C             as follows:
C             = 'S':  (A,E) is in a generalized real Schur form;
C             = 'G':  A and E are general square dense matrices.
C
C     COMPQ   CHARACTER*1
C             = 'I':  Q is initialized to the unit matrix, and the
C                     orthogonal matrix Q is returned;
C             = 'U':  Q must contain an orthogonal matrix Q1 on entry,
C                     and the product Q1*Q is returned.
C                     This option can not be used when JOBAE = 'G'.
C
C     COMPZ   CHARACTER*1
C             = 'I':  Z is initialized to the unit matrix, and the
C                     orthogonal matrix Z is returned;
C             = 'U':  Z must contain an orthogonal matrix Z1 on entry,
C                     and the product Z1*Z is returned.
C                     This option can not be used when JOBAE = 'G'.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of rows of the matrix B, the number of columns
C             of the matrix C, and the order of the square matrices A
C             and E.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of the matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The number of rows of the matrix C.  P >= 0.
C
C     NLOW,   (input) INTEGER
C     NSUP    (input) INTEGER
C             NLOW and NSUP specify the boundary indices for the rows
C             and columns of the principal subpencil of A - lambda*E
C             whose diagonal blocks are to be reordered.
C             0 <= NLOW <= NSUP <= N,       if JOBAE = 'S'.
C             NLOW = MIN( 1, N ), NSUP = N, if JOBAE = 'G'.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The boundary of the domain of interest for the generalized
C             eigenvalues of the pair (A,E). For a continuous-time
C             system (DICO = 'C'), ALPHA is the boundary value for the
C             real parts of the generalized eigenvalues, while for a
C             discrete-time system (DICO = 'D'), ALPHA >= 0 represents
C             the boundary value for the moduli of the generalized
C             eigenvalues.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the state dynamics matrix A.
C             If JOBAE = 'S' then A must be a matrix in real Schur form.
C             On exit, the leading N-by-N part of this array contains
C             the matrix Q'*A*Z in real Schur form, with the elements
C             below the first subdiagonal set to zero.
C             The leading NDIM-by-NDIM part of the principal subpencil
C             A12 - lambda*E12, defined by A12 := A(NLOW:NSUP,NLOW:NSUP)
C             and E12 := E(NLOW:NSUP,NLOW:NSUP), has generalized
C             eigenvalues in the domain of interest, and the trailing
C             part of this subpencil has generalized eigenvalues outside
C             the domain of interest.
C             The domain of interest for eig(A12,E12), the generalized
C             eigenvalues of the pair (A12,E12), is defined by the
C             parameters ALPHA, DICO and STDOM as follows:
C               For DICO = 'C':
C                  Real(eig(A12,E12)) < ALPHA if STDOM = 'S';
C                  Real(eig(A12,E12)) > ALPHA if STDOM = 'U'.
C               For DICO = 'D':
C                  Abs(eig(A12,E12)) < ALPHA if STDOM = 'S';
C                  Abs(eig(A12,E12)) > ALPHA if STDOM = 'U'.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N part of this array must
C             contain the descriptor matrix E.
C             If JOBAE = 'S', then E must be an upper triangular matrix.
C             On exit, the leading N-by-N part of this array contains an
C             upper triangular matrix Q'*E*Z, with the elements below
C             the diagonal set to zero.
C             The leading NDIM-by-NDIM part of the principal subpencil
C             A12 - lambda*E12 (see description of A) has generalized
C             eigenvalues in the domain of interest, and the trailing
C             part of this subpencil has generalized eigenvalues outside
C             the domain of interest.
C
C     LDE     INTEGER
C             The leading dimension of the array E.  LDE >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the input matrix B.
C             On exit, the leading N-by-M part of this array contains
C             the transformed input matrix Q'*B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed output matrix C*Z.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1,P).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
C             If COMPQ = 'I':  on entry, Q need not be set;
C                              on exit, the leading N-by-N part of this
C                              array contains the orthogonal matrix Q,
C                              where Q' is the product of orthogonal
C                              transformations which are applied to A,
C                              E, and B on the left.
C             If COMPQ = 'U':  on entry, the leading N-by-N part of this
C                              array must contain an orthogonal matrix
C                              Q1;
C                              on exit, the leading N-by-N part of this
C                              array contains the orthogonal matrix
C                              Q1*Q.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q. LDQ >= MAX(1,N).
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
C             If COMPZ = 'I':  on entry, Z need not be set;
C                              on exit, the leading N-by-N part of this
C                              array contains the orthogonal matrix Z,
C                              which is the product of orthogonal
C                              transformations applied to A, E, and C
C                              on the right.
C             If COMPZ = 'U':  on entry, the leading N-by-N part of this
C                              array must contain an orthogonal matrix
C                              Z1;
C                              on exit, the leading N-by-N part of this
C                              array contains the orthogonal matrix
C                              Z1*Z.
C
C     LDZ     INTEGER
C             The leading dimension of the array Z. LDZ >= MAX(1,N).
C
C     NDIM    (output) INTEGER
C             The number of generalized eigenvalues of the principal
C             subpencil A12 - lambda*E12 (see description of A) lying
C             inside the domain of interest for eigenvalues.
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
C     BETA    (output) DOUBLE PRECISION array, dimension (N)
C             On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N,
C             are the generalized eigenvalues.
C             ALPHAR(j) + ALPHAI(j)*i, and BETA(j), j = 1,...,N, are the
C             diagonals of the complex Schur form (S,T) that would
C             result if the 2-by-2 diagonal blocks of the real Schur
C             form of (A,B) were further reduced to triangular form
C             using 2-by-2 complex unitary transformations.
C             If ALPHAI(j) is zero, then the j-th eigenvalue is real;
C             if positive, then the j-th and (j+1)-st eigenvalues are a
C             complex conjugate pair, with ALPHAI(j+1) negative.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 8*N+16, if JOBAE = 'G';
C             LDWORK >= 4*N+16, if JOBAE = 'S'.
C             For optimum performance LDWORK should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed; the
C             routine only calculates the optimal size of the DWORK
C             array, returns this value as the first entry of the DWORK
C             array, and no error message related to LDWORK is issued by
C             XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the QZ algorithm failed to compute all generalized
C                   eigenvalues of the pair (A,E);
C             = 2:  a failure occured during the ordering of the
C                   generalized real Schur form of the pair (A,E).
C
C     METHOD
C
C     If JOBAE = 'G', the pair (A,E) is reduced to an ordered
C     generalized real Schur form using an orthogonal equivalence
C     transformation A <-- Q'*A*Z and E <-- Q'*E*Z. This transformation
C     is determined so that the leading diagonal blocks of the resulting
C     pair (A,E) have generalized eigenvalues in a suitably defined
C     domain of interest. Then, the transformations are applied to the
C     matrices B and C: B <-- Q'*B and C <-- C*Z.
C     If JOBAE = 'S', then the diagonal blocks of the subpencil
C     A12 - lambda*E12, defined by A12 := A(NLOW:NSUP,NLOW:NSUP)
C     and E12 := E(NLOW:NSUP,NLOW:NSUP), are reordered using orthogonal
C     equivalence transformations, such that the leading blocks have
C     generalized eigenvalues in a suitably defined domain of interest.
C
C     NUMERICAL ASPECTS
C                                     3
C     The algorithm requires about 25N  floating point operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen, October 2002.
C     Based on the RASP routine SRSFOD.
C
C     REVISIONS
C
C     V. Sima, Dec. 2016.
C
C     KEYWORDS
C
C     Deflating subspace, orthogonal transformation,
C     generalized real Schur form, equivalence transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER        COMPQ, COMPZ, DICO, JOBAE, STDOM
      INTEGER          INFO, LDA, LDB, LDC, LDE, LDQ, LDWORK, LDZ, M, N,
     $                 NDIM, NLOW, NSUP, P
      DOUBLE PRECISION ALPHA
C     .. Array Arguments ..
      DOUBLE PRECISION A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*),
     $                 BETA(*),  C(LDC,*),  DWORK(*),  E(LDE,*),
     $                 Q(LDQ,*), Z(LDZ,*)
C     .. Local Scalars ..
      LOGICAL          DISCR, LJOBG, LQUERY
      INTEGER          I, ICOMPQ, ICOMPZ, LW, MINWRK, NB, NBC, NC, NR,
     $                 SDIM, WRKOPT
C     .. Local Arrays ..
      LOGICAL          BWORK(1)
C     .. External Functions ..
      LOGICAL          DELCTG, LSAME
      EXTERNAL         DELCTG, LSAME
C     .. External Subroutines ..
      EXTERNAL         DCOPY, DGEMM, DGEQRF, DGGES, DLACPY, DLASET,
     $                 MB03QG, MB03QV, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC        INT, MAX, MIN
C
C     .. Executable Statements ..
C
C     Decode COMPQ.
C
      IF( LSAME( COMPQ, 'I' ) ) THEN
         ICOMPQ = 1
      ELSE IF( LSAME( COMPQ, 'U' ) ) THEN
         ICOMPQ = 2
      ELSE
         ICOMPQ = 0
      END IF
C
C     Decode COMPZ.
C
      IF( LSAME( COMPZ, 'I' ) ) THEN
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'U' ) ) THEN
         ICOMPZ = 2
      ELSE
         ICOMPZ = 0
      END IF
C
      INFO  = 0
      DISCR = LSAME( DICO,  'D' )
      LJOBG = LSAME( JOBAE, 'G' )
C
C     Check input scalar arguments.
C
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( LSAME( STDOM, 'S' ) .OR.
     $                 LSAME( STDOM, 'U' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT. ( LSAME( JOBAE, 'S' ) .OR. LJOBG ) ) THEN
         INFO = -3
      ELSE IF( ICOMPQ.LE.0 .OR. ( LJOBG .AND. ICOMPQ.EQ.2 ) ) THEN
         INFO = -4
      ELSE IF( ICOMPZ.LE.0 .OR. ( LJOBG .AND. ICOMPZ.EQ.2 ) ) THEN
         INFO = -5
      ELSE IF( N.LT.0 ) THEN
         INFO = -6
      ELSE IF( M.LT.0 ) THEN
         INFO = -7
      ELSE IF( P.LT.0 ) THEN
         INFO = -8
      ELSE IF(    ( LJOBG .AND. NLOW.NE.MIN( 1, N ) ) .OR.
     $       ( .NOT.LJOBG .AND. NLOW.LT.0 ) )  THEN
         INFO = -9
      ELSE IF( ( LJOBG .AND. NSUP.NE.N )  .OR. ( .NOT.LJOBG .AND.
     $         ( NSUP.LT.NLOW .OR. N.LT.NSUP ) ) ) THEN
         INFO = -10
      ELSE IF( DISCR .AND. ALPHA.LT.ZERO ) THEN
         INFO = -11
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -13
      ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -15
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -17
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -19
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -21
      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -23
      ELSE
         IF( N.EQ.0 ) THEN
            MINWRK = 1
         ELSE IF( LJOBG ) THEN
            MINWRK = 8*N + 16
         ELSE
            MINWRK = 4*N + 16
         END IF
         LQUERY = LDWORK.EQ.-1
C
C        Estimate the optimal block size.
C
         CALL DGEQRF( N, MAX( M, P ), A, LDA, DWORK, DWORK, -1, INFO )
         NB = INT( DWORK(1) )/MAX( 1, M, P )
         LW = MIN( NB*NB, N*MAX( M, P ) )
C
         IF( LQUERY ) THEN
            WRKOPT = MINWRK
            IF( LJOBG ) THEN
               CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG,
     $                     N, A, LDA, E, LDE, SDIM, ALPHAR, ALPHAI,
     $                     BETA, Q, LDQ, Z, LDZ, DWORK, -1, BWORK,
     $                     INFO )
               WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
            END IF
            CALL MB03QG( DICO, STDOM, 'Update', 'Update', N, NLOW, NSUP,
     $                   ALPHA, A, LDA, E, LDE, Q, LDQ, Z, LDZ, NDIM,
     $                   DWORK, -1, INFO )
            WRKOPT = MAX( WRKOPT, LW, INT( DWORK(1) ) )
         ELSE IF( LDWORK.LT.MINWRK ) THEN
            INFO = -29
         END IF
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TG01PD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Quick return if possible.
C
      NDIM = 0
      IF( N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF( LJOBG ) THEN
C
C        Reduce (A,E) to real generalized Schur form using an orthogonal
C        equivalence transformation (A,E) <- (Q'*A*Z,Q'*E*Z), accumulate
C        the transformations in Q and Z, and compute the generalized
C        eigenvalues of the pair (A,E) in (ALPHAR, ALPHAI, BETA).
C
C        Workspace:  need   8*N+16;
C                    prefer larger.
C
         CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG, N,
     $               A, LDA, E, LDE, SDIM, ALPHAR, ALPHAI, BETA, Q, LDQ,
     $               Z, LDZ, DWORK, LDWORK, BWORK, INFO )
         IF( INFO.NE.0 ) THEN
            INFO = 1
            RETURN
         END IF
         WRKOPT = MAX( MINWRK, INT( DWORK(1) ) )
      ELSE
C
C        Initialize Q and Z if necessary.
C
         IF( ICOMPQ.EQ.1 )
     $      CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
         IF( ICOMPZ.EQ.1 )
     $      CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
         WRKOPT = MINWRK
      END IF
C
C     Separate the spectrum of (A,E). The leading NDIM-by-NDIM subpencil
C     of A12-lambda*E12 corresponds to the generalized eigenvalues of
C     interest.
C     Workspace:  need   4*N+16.
C
      CALL MB03QG( DICO, STDOM, 'Update', 'Update', N, NLOW, NSUP,
     $             ALPHA, A, LDA, E, LDE, Q, LDQ, Z, LDZ, NDIM, DWORK,
     $             LDWORK, INFO )
      IF( INFO.NE.0 ) THEN
         INFO = 2
         RETURN
      END IF
      WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) )
C
C     Compute the generalized eigenvalues.
C
      CALL MB03QV( N, A, LDA, E, LDE, ALPHAR, ALPHAI, BETA, INFO )
C
C     Apply the transformation: B <-- Q'*B.
C
      NBC = MAX( 1, MIN( LDWORK/N, M ) )
      DO 10 I = 1, M, NBC
         NC = MIN( NBC, M-I+1 )
         CALL DGEMM( 'Transpose', 'No transpose', N, NC, N, ONE, Q, LDQ,
     $               B(1,I), LDB, ZERO, DWORK, N )
         CALL DLACPY( 'All', N, NC, DWORK, N, B(1,I), LDB )
   10 CONTINUE
C
C     Apply the transformation: C <-- C*Z.
C
      NBC = MAX( 1, MIN( LDWORK/N, P ) )
      DO 20 I = 1, P, NBC
         NR = MIN( NBC, P-I+1 )
         CALL DGEMM( 'No Transpose', 'No transpose', NR, N, N, ONE,
     $              C(I,1), LDC, Z, LDZ, ZERO, DWORK, NR )
         CALL DLACPY( 'All', NR, N, DWORK, NR, C(I,1), LDC )
   20 CONTINUE
C
      DWORK( 1 ) = MAX( WRKOPT, LW )
C
      RETURN
C *** Last line of TG01PD ***
      END