c
c**********************************************************************
      subroutine c2d_directcp(nd,sources,ns,charge,
     $           targ,nt,pot,thresh)
cf2py  intent(in) nd
cf2py  intent(in) sources,ns,charge,targ,nt,thresh
cf2py  intent(out) pot
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT
c     at the target points TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c     pot(ii)  = \sum_j log(|targ-source(*,j)|)*charge(ii,j)
c
c     The potential is not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     targ(2,nt)    :   location of the targets
c     nt            :   number of targets
c     thresh        :   threshold for computing potential
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd,nt)   (complex *16)      : potential is incremented
c---------------------------------------------------------------------
      integer i,ns,ii,nd,j,nt
      real *8 sources(2,ns),targ(2,nt),xdiff,ydiff,rr,r
      real *8 thresh,rtmp,thresh2
      complex *16 pot(nd,nt),z,ima4inv,ztmp
      complex *16 charge(nd,ns)

      thresh2 = thresh*thresh
c
      do j = 1,nt
         do i = 1,ns
            xdiff=targ(1,j)-sources(1,i)
            ydiff=targ(2,j)-sources(2,i)
            rr=xdiff*xdiff+ydiff*ydiff
            if(rr.le.thresh2) goto 1000

            rtmp = log(rr)/2
            do ii=1,nd
               pot(ii,j) = pot(ii,j) + rtmp*charge(ii,i)
            enddo
 1000       continue
         enddo
      enddo
      return
      end
c
c
c
c
c
c**********************************************************************
      subroutine c2d_directcg(nd,sources,ns,charge,targ,nt,pot,
     1             grad,thresh)
cf2py  intent(in) nd
cf2py  intent(in) sources,ns,charge,targ,nt,thresh
cf2py  intent(out) pot,grad
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT and gradients GRAD
c     at the target points TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c
c     pot(ii)  = \sum_j log(|targ-source(*,j)|)*charge(ii,j)
c
c     grad  = d/dz(pot)
c
c     The potential and gradient are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     targ(2,nt)    :   location of the targets
c     nt            :   number of targets
c     thresh        :   threshold for computing potential and gradient
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd,nt)     (complex *16)      : potential is incremented
c     grad(nd,nt)  (complex *16)      : gradient is incremented
c---------------------------------------------------------------------
      integer i,ns,ii,nd,j,nt
      real *8 sources(2,ns),targ(2,nt)
      real *8 xdiff,ydiff,rr,r,thresh,rtmp,thresh2
      complex *16 pot(nd,nt),grad(nd,nt)
      complex *16 z,ztmp,zinv
      complex *16 charge(nd,ns)

      thresh2 = thresh*thresh
c
      do j = 1,nt
         do i = 1,ns
            xdiff=targ(1,j)-sources(1,i)
            ydiff=targ(2,j)-sources(2,i)
            rr=xdiff*xdiff+ydiff*ydiff
            if(rr.lt.thresh2) goto 1000
            rtmp = log(rr)/2
            z=dcmplx(xdiff,ydiff)
            zinv = 1/z
c
            do ii = 1,nd
               pot(ii,j) = pot(ii,j) + rtmp*charge(ii,i)
               grad(ii,j) = grad(ii,j) + zinv*charge(ii,i)
            enddo
 1000       continue
         enddo
      enddo

      return
      end
c
c
c
c
c
c
c
c
c**********************************************************************
      subroutine c2d_directch(nd,sources,ns,charge,targ,nt,
     1           pot,grad,hess,thresh)
cf2py  intent(in) nd
cf2py  intent(in) sources,ns,charge,targ,nt,thresh
cf2py  intent(out) pot,grad,hess
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT, gradients GRAD
c     and Hessians at the target points TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c
c     pot(ii)  = \sum_j log(|targ-source(*,j)|)*charge(ii,j)
c
c     grad  = d/dz(pot)
c     hess = d^2/dz^2(pot)
c
c     The potential and gradient are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     targ(2,nt)    :   location of the targets
c     nt            :   number of targets
c     thresh        :   threshold for computing potential,gradient,and
c                       hessian
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd,nt)     (complex *16)      : potential is incremented
c     grad(nd,nt)  (complex *16)      : gradient is incremented
c     hess(nd,nt)  (complex *16)      : Hessian is incremented
c---------------------------------------------------------------------
      integer i,ns,ifexpon,ii,nd,j,nt
      real *8 sources(2,ns),targ(2,nt)
      real *8 xdiff,ydiff,rr,r,thresh,thresh2
      complex *16 pot(nd,nt),grad(nd,nt),hess(nd,nt)
      real *8 rtmp
      complex *16 z,zinv,ztmp
      complex *16 charge(nd,ns)

      thresh2 = thresh*thresh

c
      do j = 1,nt
         do i = 1,ns
            xdiff=targ(1,j)-sources(1,i)
            ydiff=targ(2,j)-sources(2,i)
            rr=xdiff*xdiff+ydiff*ydiff
            if(rr.lt.thresh2) goto 1000
            rtmp = log(rr)/2
            z=dcmplx(xdiff,ydiff)
            zinv = 1/z
            ztmp = -zinv*zinv
c
            do ii = 1,nd
               pot(ii,j) = pot(ii,j) + rtmp*charge(ii,i)
               grad(ii,j) = grad(ii,j) + zinv*charge(ii,i)
               hess(ii,j) = hess(ii,j) + ztmp*charge(ii,i)
            enddo
 1000       continue
         enddo
      enddo

      return
      end
c
c
c
c
c
c**********************************************************************
      subroutine c2d_directdp(nd,sources,ns,dipstr,
     $           targ,nt,pot,thresh)
cf2py  intent(in) nd
cf2py  intent(in) sources,ns,dipstr,targ,nt,thresh
cf2py  intent(out) pot
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT
c     at the target points TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c      z_j = cmplx(targ - source(:,j))
c
c     pot(ii)  = \sum_j dipstr(ii,j)/z_j
c
c     The potential is not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     dipstr(nd,ns) :   dipole strengths
c     targ(2,nt)    :   location of the targets
c     nt            :   number of targets
c     thresh        :   threshold for computing potential
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd,nt)   (complex *16)      : potential is incremented
c---------------------------------------------------------------------
      integer i,ns,ii,nd,j,nt
      real *8 sources(2,ns),targ(2,nt),xdiff,ydiff,rr,r
      real *8 thresh,rtmp
      complex *16 pot(nd,nt),z,zinv
      complex *16 dipstr(nd,ns)
c
      do j = 1,nt
         do i = 1,ns
            xdiff=targ(1,j)-sources(1,i)
            ydiff=targ(2,j)-sources(2,i)
            z = dcmplx(xdiff,ydiff)
            if(abs(z).le.thresh) goto 1000

            zinv = 1/z
            do ii=1,nd
               pot(ii,j) = pot(ii,j) + zinv*dipstr(ii,i)
            enddo
 1000       continue
         enddo
      enddo
      return
      end
c
c
c
c
c
c**********************************************************************
      subroutine c2d_directdg(nd,sources,ns,dipstr,targ,nt,pot,
     1             grad,thresh)
cf2py  intent(in) nd
cf2py  intent(in) sources,ns,dipstr,targ,nt,thresh
cf2py  intent(out) pot,grad
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT and gradients GRAD
c     at the target points TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c      z_j = cmplx(targ - source(:,j))
c
c     pot(ii)  = \sum_j dipstr(ii,j)/z_j
c
c     grad  = d/dz(pot)
c
c     The potential and gradient are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     dipstr(nd,ns) :   charge strengths
c     targ(2,nt)    :   location of the targets
c     nt            :   number of targets
c     thresh        :   threshold for computing potential and gradient
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd,nt)     (complex *16)    : potential is incremented
c     grad(nd,nt)  (complex *16)      : gradient is incremented
c---------------------------------------------------------------------
      integer i,ns,ii,nd,j,nt
      real *8 sources(2,ns),targ(2,nt)
      real *8 xdiff,ydiff,rr,r,thresh,rtmp
      complex *16 pot(nd,nt),grad(nd,nt)
      complex *16 z,zinv,ztmp2
      complex *16 dipstr(nd,ns)
c
      do j = 1,nt
         do i = 1,ns
            xdiff=targ(1,j)-sources(1,i)
            ydiff=targ(2,j)-sources(2,i)
            z=dcmplx(xdiff,ydiff)
            if(abs(z).lt.thresh) goto 1000
            zinv = 1/z
            ztmp2 = -zinv*zinv
c
            do ii = 1,nd
               pot(ii,j) = pot(ii,j) + zinv*dipstr(ii,i)
               grad(ii,j) = grad(ii,j) + ztmp2*dipstr(ii,i)
            enddo
 1000       continue
         enddo
      enddo

      return
      end
c
c
c
c
c
c
c
c
c**********************************************************************
      subroutine c2d_directdh(nd,sources,ns,dipstr,targ,nt,
     1           pot,grad,hess,thresh)
cf2py  intent(in) nd
cf2py  intent(in) sources,ns,dipstr,targ,nt,thresh
cf2py  intent(out) pot,grad,hess
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT, gradients GRAD
c     and Hessians at the target points TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c      z_j = cmplx(targ - source(:,j))
c
c     pot(ii)  = \sum_j dipstr(ii,j)/z_j
c
c     grad  = d/dz(pot)
c     hess = d^2/dz^2(pot)
c
c     The potential and gradient are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     dipstr(nd,ns) :   charge strengths
c     targ(2,nt)    :   location of the targets
c     nt            :   number of targets
c     thresh        :   threshold for computing potential,gradient,and
c                       hessian
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd,nt)     (complex *16)      : potential is incremented
c     grad(nd,nt)  (complex *16)      : gradient is incremented
c     hess(nd,nt)  (complex *16)      : Hessian is incremented
c---------------------------------------------------------------------
      integer i,ns,ifexpon,ii,nd,j,nt
      real *8 sources(2,ns),targ(2,nt)
      real *8 xdiff,ydiff,rr,r,thresh
      complex *16 pot(nd,nt),grad(nd,nt),hess(nd,nt)
      real *8 rtmp
      complex *16 z,zinv,ztmp2,ztmp3
      complex *16 dipstr(nd,ns)

c
      do j = 1,nt
         do i = 1,ns
            xdiff=targ(1,j)-sources(1,i)
            ydiff=targ(2,j)-sources(2,i)
            z = dcmplx(xdiff,ydiff)
            if(abs(z).lt.thresh) goto 1000
            zinv = 1/z
            ztmp2 = -zinv*zinv
            ztmp3 = -2*ztmp2*zinv
c
            do ii = 1,nd
               pot(ii,j) = pot(ii,j) + zinv*dipstr(ii,i)
               grad(ii,j) = grad(ii,j) + ztmp2*dipstr(ii,i)
               hess(ii,j) = hess(ii,j) + ztmp3*dipstr(ii,i)
            enddo
 1000       continue
         enddo
      enddo

      return
      end
c
c
c
c
c
c**********************************************************************
      subroutine c2d_directcdp(nd,sources,ns,charge,
     $           dipstr,targ,nt,pot,thresh)
cf2py  intent(in) nd
cf2py  intent(in) sources,ns,charge,dipstr,targ,nt,thresh
cf2py  intent(out) pot
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT
c     at the target points TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c     z_j = cmplx(targ - source(:,j))
c     pot(ii)  = \sum_j log(|z_{j}|)*charge(ii,j)+
c           dipstr(ii,j)/z_{j}
c
c     The potential is not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     dipstr(nd,ns) :   dipole strengths
c     targ(2,nt)    :   location of the targets
c     nt            :   number of targets
c     thresh        :   threshold for computing potential
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd,nt)   (complex *16)      : potential is incremented
c---------------------------------------------------------------------
      integer i,ns,ii,nd,j,nt
      real *8 sources(2,ns),targ(2,nt),xdiff,ydiff,rr,r
      real *8 thresh,rtmp,thresh2
      complex *16 pot(nd,nt),z,ztmp,zinv
      complex *16 charge(nd,ns),dipstr(nd,ns)

      thresh2 = thresh*thresh
c
      do j = 1,nt
         do i = 1,ns
            xdiff=targ(1,j)-sources(1,i)
            ydiff=targ(2,j)-sources(2,i)
            rr=xdiff*xdiff+ydiff*ydiff
            if(rr.le.thresh2) goto 1000

            rtmp = log(rr)/2.0d0
            z = dcmplx(xdiff,ydiff)
            zinv = 1/z
            do ii=1,nd
               pot(ii,j) = pot(ii,j) + rtmp*charge(ii,i)
     1                               + zinv*dipstr(ii,i)
            enddo
 1000       continue
         enddo
      enddo
      return
      end
c
c
c
c
c
c**********************************************************************
      subroutine c2d_directcdg(nd,sources,ns,charge,dipstr,targ,nt,pot,
     1             grad,thresh)
cf2py  intent(in) nd
cf2py  intent(in) sources,ns,charge,dipstr,targ,nt,thresh
cf2py  intent(out) pot,grad
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT and gradients GRAD
c     at the target points TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c     pot(ii)  = \sum_j log(|z_{j}|)*charge(ii,j)+
c           dipstr(ii,j)/z_{j}
c
c     grad  = d/dz(pot)
c
c     The potential and gradient are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     dipstr(nd,ns) :   charge strengths
c     targ(2,nt)    :   location of the targets
c     nt            :   number of targets
c     thresh        :   threshold for computing potential and gradient
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd,nt)     (complex *16)      : potential is incremented
c     grad(nd,nt)  (complex *16)      : gradient is incremented
c---------------------------------------------------------------------
      integer i,ns,ii,nd,j,nt
      real *8 sources(2,ns),targ(2,nt)
      real *8 xdiff,ydiff,rr,r,thresh,rtmp,thresh2
      complex *16 pot(nd,nt),grad(nd,nt)
      complex *16 z,ztmp,zinv,ztmp2
      complex *16 charge(nd,ns),dipstr(nd,ns)

      thresh2 = thresh*thresh
c
      do j = 1,nt
         do i = 1,ns
            xdiff=targ(1,j)-sources(1,i)
            ydiff=targ(2,j)-sources(2,i)
            rr=xdiff*xdiff+ydiff*ydiff
            if(rr.lt.thresh2) goto 1000
            rtmp = log(rr)/2
            z=dcmplx(xdiff,ydiff)
            zinv = 1/z
            ztmp2 = -zinv*zinv
c
            do ii = 1,nd
               pot(ii,j) = pot(ii,j) + rtmp*charge(ii,i)
     1                               + zinv*dipstr(ii,i)
               grad(ii,j) = grad(ii,j) + zinv*charge(ii,i)
     1                                 + ztmp2*dipstr(ii,i)
            enddo
 1000       continue
         enddo
      enddo

      return
      end
c
c
c
c
c
c
c
c
c**********************************************************************
      subroutine c2d_directcdh(nd,sources,ns,charge,dipstr,targ,nt,
     1           pot,grad,hess,thresh)
cf2py  intent(in) nd
cf2py  intent(in) sources,ns,charge,dipstr,targ,nt,thresh
cf2py  intent(out) pot,grad,hess
      implicit none
c**********************************************************************
c
c     This subroutine INCREMENTS the potentials POT, gradients GRAD
c     and Hessians at the target points TARGET, due to a vector of
c     charges at SOURCE(2,ns).
c     We use the unscaled version of log
c     response: i.e., log|z|
c
c
c     pot(ii)  = \sum_j log(|z_{j}|)*charge(ii,j)+
c           dipstr(ii,j)/z_{j}
c
c     grad  = d/dz(pot)
c     hess = d^2/dz^2(pot)
c
c     The potential and gradient are not computed if |r| < thresh
c     (Recommended value for threshold in an FMM is
c     R*eps, where R is the size of the computation
c     domain and eps is machine precision
c
c---------------------------------------------------------------------
c     INPUT:
c
c     sources(2,ns) :   location of the sources
c     ns            :   number of sources
c     charge(nd,ns) :   charge strengths
c     dipstr(nd,ns) :   dipole strengths
c     targ(2,nt)    :   location of the targets
c     nt            :   number of targets
c     thresh        :   threshold for computing potential,gradient,and
c                       hessian
c---------------------------------------------------------------------
c     OUTPUT:
c
c     pot(nd,nt)     (complex *16)      : potential is incremented
c     grad(nd,nt)  (complex *16)      : gradient is incremented
c     hess(nd,nt)  (complex *16)      : Hessian is incremented
c---------------------------------------------------------------------
      integer i,ns,ifexpon,ii,nd,j,nt
      real *8 sources(2,ns),targ(2,nt)
      real *8 xdiff,ydiff,rr,r,thresh,thresh2
      complex *16 pot(nd,nt),grad(nd,nt),hess(nd,nt)
      real *8 rtmp
      complex *16 z,zinv,ztmp2,ztmp3
      complex *16 charge(nd,ns),dipstr(nd,ns)

      thresh2 = thresh*thresh

c
      do j = 1,nt
         do i = 1,ns
            xdiff=targ(1,j)-sources(1,i)
            ydiff=targ(2,j)-sources(2,i)
            rr=xdiff*xdiff+ydiff*ydiff
            if(rr.lt.thresh2) goto 1000
            rtmp = log(rr)/2
            z=dcmplx(xdiff,ydiff)
            zinv = 1/z
            ztmp2 = -zinv*zinv
            ztmp3 = -2*ztmp2*zinv
c
            do ii = 1,nd
               pot(ii,j) = pot(ii,j) + rtmp*charge(ii,i)
     1                               + zinv*dipstr(ii,i)
               grad(ii,j) = grad(ii,j) + zinv*charge(ii,i)
     1                                 + ztmp2*dipstr(ii,i)
               hess(ii,j) = hess(ii,j) + ztmp2*charge(ii,i)
     1                                 + ztmp3*dipstr(ii,i)
            enddo
 1000       continue
         enddo
      enddo

      return
      end
c
c
c


      subroutine ubarspinor0(q,i,f)
c-----subroutine for massless ubar spinor
!     Majorana representation
      implicit none
      include 'constants.f'
      include 'swapxz.f'
      integer i
      double complex p(4),q(4),f(4),fc
      double precision  Ep,px,py,pz,phase,rtEon2
      logical,save::first
      data first/.true./

      if (first) then
      write(6,*) 'ubarspinor0:swapxz=',swapxz
      first=.false.
      endif

      if (swapxz) then
C performing the swap (x<->z),(y->-y)
      p(1)=q(4)
      p(2)=q(3)
      p(3)=-q(2)
      p(4)=q(1)
      else
      p(1)=q(4)
      p(2)=q(1)
      p(3)=q(2)
      p(4)=q(3)
      endif

      Ep=+dreal(p(1))
      px=+dreal(p(2))
      py=+dreal(p(3))
      pz=+dreal(p(4))

      fc=sqrt(p(1)+p(4))
      if (dble(p(1)+p(4)) .gt. 0) then
        phase=1d0
      else
        phase=-1d0
      endif

      if (abs(fc).gt.1D-8) then
      if (i .eq. 1) then
      f(1)=dcmplx(Ep+pz-py,-px)/(2d0*fc)
      f(2)=+im*f(1)
      f(3)=dcmplx(Ep+pz+py,px)/(2d0*fc)
      f(4)=-im*f(3)
      elseif (i .eq. -1) then
      f(1)=dcmplx(px,-Ep-pz+py)/(2d0*fc)
      f(2)=-im*f(1)
      f(3)=dcmplx(-px,-Ep-pz-py)/(2d0*fc)
      f(4)=+im*f(3)
      endif

      else
      rtEon2=sqrt(Ep/2d0)
      if (i .eq. 1) then
        f(1)=dcmplx(0d0,-rtEon2)
        f(2)=+im*f(1)
        f(3)=dcmplx(0d0,+rtEon2)
        f(4)=-im*f(3)
       elseif (i .eq. -1) then
        f(1)=dcmplx(rtEon2,0d0)
        f(2)=-im*f(1)
        f(3)=dcmplx(-rtEon2,0d0)
        f(4)=+im*f(3)
      endif
      endif
      return
      end


!-----------------------------------------
subroutine vortex_force_calc(U_k, U_j, vort_k, vort_j, res, order, l, m, n)

  implicit none

  integer, intent(in):: l, m, n, order
  real*8, dimension(l, m, n), intent(in) :: U_k, U_j , vort_k, vort_j
  real*8, dimension(l, m, n), intent(inout) :: res

  !f2py intent(inplace):: vort_k, vort_j, res, U_k, U_j

  integer:: i, j, k
  integer, parameter :: out_unit=30
  real*8:: c1,c2,c3, b1, b2, b3, b4, b5
  real*8:: UU_k, up_k, um_k, qm_k, qp_k, U_k_interp, UU_j, up_j, um_j, qm_j, qp_j, U_j_interp, U_omega

  c1 = -1./6.
  c2 =  5./6.
  c3 =  2./6.

  b1 = 2./60.
  b2 = -13./60.
  b3 = 47./60.
  b4 = 27./60.
  b5 = -3./60.

  do k = 1,l
    do j = 1,m
      do i = 1,n

        !w_j U_k
        if ((k.gt.1).and.(j.lt.m)) then
          U_k_interp = 0.25 * ( U_k(k, j, i) + U_k(k-1, j, i) + U_k(k-1, j+1, i) + U_k(k, j+1, i) )
        elseif (j.lt.m) then
          U_k_interp = 0.25 * ( U_k(k, j+1, i) + U_k(k, j, i)) !no normal velocity
        else
        endif

        UU_k = abs(U_k_interp)
        up_k = 0.5*(U_k_interp+UU_k) ! right-going flux
        um_k = 0.5*(U_k_interp-UU_k) ! left-going flux

        !write(out_unit,*) "up_k ", up_k, "um_k", um_k

        if ((i.gt.2).and.(order.eq.5)) then
           qp_j = b1*vort_j(k,j,i-2) + b2*vort_j(k,j,i-1) + b3*vort_j(k,j,i) + b4*vort_j(k,j,i+1) + b5*vort_j(k,j,i+2)
        elseif ((i.gt.1).and.(order.ge.3)) then
           qp_j = c1*vort_j(k,j,i-1) + c2*vort_j(k,j,i) + c3*vort_j(k,j,i+1)
        else
           qp_j = vort_j(k,j,i)
        endif

        if ((i.le.(n-3)).and.(order.eq.5)) then
           qm_j = b5*vort_j(k,j,i-1) + b4*vort_j(k,j,i) + b3*vort_j(k,j,i+1) + b2*vort_j(k,j,i+2) + b1*vort_j(k,j,i+3)
        elseif ((i.le.(n-2)).and.(order.ge.3)) then
           qm_j = c3*vort_j(k,j,i) + c2*vort_j(k,j,i+1) + c1*vort_j(k,j,i+2)
        elseif (i.le.(n-1)) then
           qm_j = vort_j(k,j,i+1)
        else
           ! no flux through the boundary
           ! TODO: change this in case of inflow/outflow
           ! cf Winters 2012
           qm_j = 0.
        endif

        !w_k U_j
        if ((k.gt.1).and.(i.lt.m)) then
          U_j_interp = 0.25 * ( U_j(k, j, i) + U_j(k-1, j, i) + U_j(k-1, j, i+1) + U_j(k, j, i+1) )
        elseif (k.lt.l) then
          U_j_interp = 0.25 * ( U_j(k+1, j, i) + U_j(k, j, i)) !no normal velocity
        else
        endif

        UU_j = abs(U_j_interp)
        up_j = 0.5*(U_j_interp+UU_j) ! right-going flux
        um_j = 0.5*(U_j_interp-UU_j) ! left-going flux

        !write(out_unit,*) "up_j ", up_j, "um_j", um_j

        if ((j.gt.2).and.(order.eq.5)) then
           qp_k = b1*vort_k(k,j-2,i) + b2*vort_k(k,j-1,i) + b3*vort_k(k,j,i) + b4*vort_k(k,j+1,i) + b5*vort_k(k,j+2,i)
        elseif ((j.gt.1).and.(order.ge.3)) then
           qp_k = c1*vort_k(k,j-1,i) + c2*vort_k(k,j,i) + c3*vort_k(k,j+1,i)
        else
           qp_k = vort_k(k,j,i)
        endif

        if ((j.le.(m-3)).and.(order.eq.5)) then
           qm_k = b5*vort_k(k,j-1,i) + b4*vort_k(k,j,i) + b3*vort_k(k,j+1,i) + b2*vort_k(k,j+2,i) + b1*vort_k(k,j+3,i)
        elseif ((j.le.(m-2)).and.(order.ge.3)) then
           qm_k = c3*vort_k(k,j,i) + c2*vort_k(k,j+1,i) + c1*vort_k(k,j+2,i)
        elseif (j.lt.m) then
           qm_k = vort_k(k,j+1,i)
        else
           ! no flux through the boundary
           ! TODO: change this in case of inflow/outflow
           ! cf Winters 2012
           qm_k = 0.
        endif

        !write(out_unit,*), "qm_j", qm_j, "qp_j", qp_j, "qp_k", qp_k, "qm_k", qm_k

        ! this term is U_j * omega_k

        U_omega =  (up_k*qp_j + um_k*qm_j) - ( up_j * qp_k + um_j * qm_k)

        !write(out_unit,*) "U_omega ", U_omega

        res(k,j,i) = res(k,j,i) - U_omega

      end do
    end do
  end do

end subroutine vortex_force_calc


program num_inquiry
! DIGITS (X)                         Number of significant digits of the model
! EPSILON (X)                        Number that is almost negligible
!                                       compared to one
! HUGE (X)                           Largest number of the model
! MAXEXPONENT (X)                    Maximum exponent of the model
! MINEXPONENT (X)                    Minimum exponent of the model
! PRECISION (X)                      Decimal precision
! RADIX (X)                          Base of the model
! RANGE (X)                          Decimal exponent range
! TINY (X)                           Smallest positive number of the model
  implicit none
  integer :: I
  real :: X
  double precision :: D
  complex :: C
  print *, "X = real"
  print *, "DIGITS (X)=", DIGITS (X)
  print *, "EPSILON (X) =", EPSILON (X)
  print *, "HUGE (X) =", HUGE (X)
  print *, "MAXEXPONENT (X) =", MAXEXPONENT (X)
  print *, "MINEXPONENT (X) =", MINEXPONENT (X)
  print *, "PRECISION (X) =", PRECISION (X)
  print *, "RADIX (X) =", RADIX (X)
  print *, "RANGE (X) =", RANGE (X)
  print *, "TINY (X) =", TINY (X)

  print *, "D = double precision"
  print *, "DIGITS (D)=", DIGITS (D)
  print *, "EPSILON (D) =", EPSILON (D)
  print *, "HUGE (D) =", HUGE (D)
  print *, "MAXEXPONENT (D) =", MAXEXPONENT (D)
  print *, "MINEXPONENT (D) =", MINEXPONENT (D)
  print *, "PRECISION (D) =", PRECISION (D)
  print *, "RADIX (D) =", RADIX (D)
  print *, "RANGE (D) =", RANGE (D)
  print *, "TINY (D) =", TINY (D)

  print *, "I = integer"
  print *, "DIGITS (I)=", DIGITS (I)
  print *, "EPSILON (I) =", EPSILON (I)  ! no-no: must be real
  print *, "HUGE (I) =", HUGE (I)
  print *, "MAXEXPONENT (I) =", MAXEXPONENT (I)  ! no-no: must be real
  print *, "MINEXPONENT (I) =", MINEXPONENT (I)  ! no-no: must be real
  print *, "PRECISION (I) =", PRECISION (I)  ! no-no: must be real or complex
  print *, "RADIX (I) =", RADIX (I)
  print *, "RANGE (I) =", RANGE (I)
  print *, "TINY (I) =", TINY (I)  ! no-no: must be real

  print *, "C = complex"
  print *, "DIGITS (C)=", DIGITS (C)  ! no-no: must be real
  print *, "EPSILON (C) =", EPSILON (C)   ! no-no: must be real
  print *, "HUGE (C) =", HUGE (C)   ! no-no: must be real
  print *, "MAXEXPONENT (C) =", MAXEXPONENT (C)   ! no-no: must be real
  print *, "MINEXPONENT (C) =", MINEXPONENT (C)   ! no-no: must be real
  print *, "PRECISION (C) =", PRECISION (C)
  print *, "RADIX (C) =", RADIX (C)   ! no-no: must be real
  print *, "RANGE (C) =", RANGE (C)
  print *, "TINY (C) =", TINY (C)   ! no-no: must be real
end program num_inquiry


	SUBROUTINE LILOPLOT(NPT,ITER,BX,BY,XX,YY,ZZ)
C
	COMMON /MONGOPAR/
     1  X1,X2,Y1,Y2,GX1,GX2,GY1,GY2,LX1,LX2,LY1,LY2,
     1  GX,GY,CX,CY,
     1  EXPAND,ANGLE,LTYPE,LWEIGHT,
     1  CHEIGHT,CWIDTH,CXDEF,CYDEF,PXDEF,PYDEFF,COFFMGO,
     1  TERMOUT,XYSWAPPED,NUMDEV,
     1  PIMGO,USERVAR(10),AUTODOT
	COMMON /FREQS/ NC,FC(10),FP,FLH,FUH
C
        DIMENSION XX(1),YY(1),ZZ(1)
C
C	ITER NE 0 IS TERMINAL, ITER = 0 IS HARDCOPY
C
	YMINA = -BY
	YMAXA = BY
	XMINA = XX(1)
	XMAXA = XMINA
	XMIN = ALOG10(ABS(XX(1)))
	XMAX = XMIN
	DO N = 1,NPT
	YMINA = AMIN1(YMINA,YY(N))
	YMINA = AMIN1(YMINA,ZZ(N))
	YMAXA = AMAX1(YMAXA,YY(N))
	YMAXA = AMAX1(YMAXA,ZZ(N))
	YY(N) = FLILO(YY(N),BY)
	ZZ(N) = FLILO(ZZ(N),BY)
	XMINA = AMIN1(XX(N),XMINA)
	XMAXA = AMAX1(XX(N),XMAXA)
	ENDDO
	NYMIN = ALOG10(-YMINA)
	YMINT = -(NYMIN+1)
	NYMAX = ALOG10(YMAXA)
	YMAXT = NYMAX + 1
	PRINT*,'MIN AND MAX OF     FREQ',XMINA,XMAXA
	PRINT*,'MIN AND MAX OF       Y',YMINA,YMAXA
	PRINT*,'INTEGER MIN AND MAX OF LOG10 Y',YMINT,YMAXT

C
C	LEAVE SPACE AT END
	XMAX = XMAX + .7
        CALL MGOINIT
        IF(ITER.NE.0) CALL MGOSETUP(3)                       !TERMINAL
        IF(ITER.EQ.0) CALL MGOSETUP(-6)                       !LASER PRINTER
        CALL MGOERASE
        !CALL MGOWINDOW(2,1,1)
	YMAXL = FLILO(10.**YMAXT,BY)
	YMINL = -FLILO(10.**(-YMINT),BY)
	PRINT*,'MIN AND MAX OF Y LIMITS',YMINL,YMAXL
 	print*,'user limits',x1,x2,y1,y2
 	print*,'dev limits',gx1,gx2,gy1,gy2
C	TOP AND BOTTOM
	IF(XMINA*XMAXA.GT.0.) THEN
	DO N = 1,NPT
 	 XX(N) = ALOG10(ABS(XX(N)))
	 XMIN = AMIN1(XX(N),XMIN)
	 XMAX = AMAX1(XX(N),XMAX)
	ENDDO
         CALL MGOSETLIM( XMIN,YMINL,XMAX,YMAXL)
	 CALL MGOAXIS(XMIN,XMAX,-1.,-1.,GX1,GY1,GX2,GY1,101,0)
	 CALL MGOAXIS(XMIN,XMAX,-1.,-1.,GX1,GY2,GX2,GY2,100,1)
	ELSE
	DO N = 1,NPT
 	 XX(N) = FLILO(XX(N),BX)
	 XMIN = AMIN1(XX(N),XMIN)
	 XMAX = AMAX1(XX(N),XMAX)
	ENDDO
	 NXMIN = ALOG10(-XMINA)
	 XMINT = -(NXMIN+1)
	 NXMAX = ALOG10(XMAXA)
	 XMAXT = NXMAX + 1
	 XMAXL = FLILO(10.**XMAXT,BX)
	 XMINL = -FLILO(10.**(-XMINT),BX)
         CALL MGOSETLIM( XMINL,YMINL,XMAXL,YMAXL)
	 BL = ALOG10(BX)                          ! FIRST LABEL
	 CALL MGORELOCATE(BX,GY1)
	 XB2 = GX
C	TOP AND BOTTOM
	 CALL MGOAXIS(BL,XMAXT,-1.,-1.,GX,GY1,GX2,GY1,100,0)
	 CALL MGORELOCATE(BX,GY1)
	 CALL MGOAXIS(BL,XMAXT,-1.,-1.,GX,GY2,GX2,GY2,100,1)
	 CALL MGORELOCATE(-BX,GY1)
	 XB1 = GX
	 CALL MGOAXIS(BL,-XMINT,-1.,-1.,GX,GY1,GX1,GY1,100,1)
	 CALL MGORELOCATE(-BX,GY2)
	 CALL MGOAXIS(BL,-XMINT,-1.,-1.,GX,GY2,GX1,GY2,100,0)
C	DO LINEAR PART
	 CALL MGOAXIS(-BX,BX,BX,BX,XB1,GY1,XB2,GY1,101,0)
	 CALL MGOAXIS(-BX,BX,BX,BX,XB1,GY2,XB2,GY2,100,1)
	ENDIF
C	SIDES
	BL = ALOG10(BY)                          ! FIRST LABEL
	CALL MGORELOCATE(GX1,BY)
	CALL MGOAXIS(BL,YMAXT,-1.,-1.,GX1,GY,GX1,GY2,100,1)
	CALL MGORELOCATE(GX1,BY)
	CALL MGOAXIS(BL,YMAXT,-1.,-1.,GX2,GY,GX2,GY2,100,0)
	CALL MGORELOCATE(GX1,-BY)
	CALL MGOAXIS(BL,-YMINT,-1.,-1.,GX1,GY,GX1,GY1,100,0)
	CALL MGORELOCATE(GX1,-BY)
	CALL MGOAXIS(BL,-YMINT,-1.,-1.,GX2,GY,GX2,GY1,100,1)
C	DO LINEAR PART
	CALL MGORELOCATE(GX1,BY)
	YB2 = GY
	CALL MGORELOCATE(GX1,-BY)
	YB1 = GY
	CALL MGOAXIS(-BY,BY,BY,BY,GX1,YB1,GX1,YB2,102,1)
	CALL MGOAXIS(-BY,BY,BY,BY,GX2,YB1,GX2,YB2,100,0)
        CALL MGOCONNECT(XX,YY,NPT)
	CALL MGOSETLTYPE(2)
        CALL MGOCONNECT(XX,ZZ,NPT)
	CALL MGOSETLTYPE(0)
        CALL MGOXLABEL(14,'FREQUENCY (HZ)')
        CALL MGOYLABEL(5,' DEQ ')
C
        IF(ITER.NE.0) CALL MGOTIDLE
	IF(ITER.EQ.0) CALL MGOPRNTPLOT(NVEC)
        RETURN
        END


      SUBROUTINE HFTI(A,MDA,M,N,B,MDB,NB,TAU,KRANK,RNORM,H,G,IP)

C     RANK-DEFICIENT LEAST SQUARES ALGORITHM AS DESCRIBED IN:
C     C.L.LAWSON AND R.J.HANSON, JET PROPULSION LABORATORY, 1973 JUN 12
C     TO APPEAR IN 'SOLVING LEAST SQUARES PROBLEMS', PRENTICE-HALL, 1974

C     A(*,*),MDA,M,N   THE ARRAY A INITIALLY CONTAINS THE M x N MATRIX A
C                      OF THE LEAST SQUARES PROBLEM AX = B.
C                      THE FIRST DIMENSIONING PARAMETER MDA MUST SATISFY
C                      MDA >= M. EITHER M >= N OR M < N IS PERMITTED.
C                      THERE IS NO RESTRICTION ON THE RANK OF A.
C                      THE MATRIX A WILL BE MODIFIED BY THE SUBROUTINE.
C     B(*,*),MDB,NB    IF NB = 0 THE SUBROUTINE WILL MAKE NO REFERENCE
C                      TO THE ARRAY B. IF NB > 0 THE ARRAY B() MUST
C                      INITIALLY CONTAIN THE M x NB MATRIX B  OF THE
C                      THE LEAST SQUARES PROBLEM AX = B AND ON RETURN
C                      THE ARRAY B() WILL CONTAIN THE N x NB SOLUTION X.
C                      IF NB>1 THE ARRAY B() MUST BE DOUBLE SUBSCRIPTED
C                      WITH FIRST DIMENSIONING PARAMETER MDB>=MAX(M,N),
C                      IF NB=1 THE ARRAY B() MAY BE EITHER SINGLE OR
C                      DOUBLE SUBSCRIPTED.
C     TAU              ABSOLUTE TOLERANCE PARAMETER FOR PSEUDORANK
C                      DETERMINATION, PROVIDED BY THE USER.
C     KRANK            PSEUDORANK OF A, SET BY THE SUBROUTINE.
C     RNORM            ON EXIT, RNORM(J) WILL CONTAIN THE EUCLIDIAN
C                      NORM OF THE RESIDUAL VECTOR FOR THE PROBLEM
C                      DEFINED BY THE J-TH COLUMN VECTOR OF THE ARRAY B.
C     H(), G()         ARRAYS OF WORKING SPACE OF LENGTH >= N.
C     IP()             INTEGER ARRAY OF WORKING SPACE OF LENGTH >= N
C                      RECORDING PERMUTATION INDICES OF COLUMN VECTORS

      INTEGER          I,J,JB,K,KP1,KRANK,L,LDIAG,LMAX,M,
     .                 MDA,MDB,N,NB,IP(N)
      DOUBLE PRECISION A(MDA,N),B(MDB,NB),H(N),G(N),RNORM(NB),FACTOR,
     .                 TAU,ZERO,HMAX,DIFF,TMP,DDOT,DNRM2,U,V
      DIFF(U,V)=       U-V
      DATA             ZERO/0.0D0/, FACTOR/1.0D-3/

      K=0
      LDIAG=MIN(M,N)
      IF(LDIAG.LE.0)                  GOTO 270

C   COMPUTE LMAX

      DO 80 J=1,LDIAG
          IF(J.EQ.1)                  GOTO 20
          LMAX=J
          DO 10 L=J,N
              H(L)=H(L)-A(J-1,L)**2
   10         IF(H(L).GT.H(LMAX)) LMAX=L
          IF(DIFF(HMAX+FACTOR*H(LMAX),HMAX).GT.ZERO)
     .                                GOTO 50
   20     LMAX=J
          DO 40 L=J,N
              H(L)=ZERO
              DO 30 I=J,M
   30             H(L)=H(L)+A(I,L)**2
   40         IF(H(L).GT.H(LMAX)) LMAX=L
          HMAX=H(LMAX)

C   COLUMN INTERCHANGES IF NEEDED

   50     IP(J)=LMAX
          IF(IP(J).EQ.J)              GOTO 70
          DO 60 I=1,M
              TMP=A(I,J)
              A(I,J)=A(I,LMAX)
   60         A(I,LMAX)=TMP
          H(LMAX)=H(J)

C   J-TH TRANSFORMATION AND APPLICATION TO A AND B

   70     I=MIN(J+1,N)
          CALL H12(1,J,J+1,M,A(1,J),1,H(J),A(1,I),1,MDA,N-J)
   80     CALL H12(2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB)

C   DETERMINE PSEUDORANK

      DO 90 J=1,LDIAG
   90     IF(ABS(A(J,J)).LE.TAU)      GOTO 100
      K=LDIAG
      GOTO 110
  100 K=J-1
  110 KP1=K+1

C   NORM OF RESIDUALS

      DO 130 JB=1,NB
  130     RNORM(JB)=DNRM2(M-K,B(KP1,JB),1)
      IF(K.GT.0)                      GOTO 160
      DO 150 JB=1,NB
          DO 150 I=1,N
  150         B(I,JB)=ZERO
      GOTO 270
  160 IF(K.EQ.N)                      GOTO 180

C   HOUSEHOLDER DECOMPOSITION OF FIRST K ROWS

      DO 170 I=K,1,-1
  170     CALL H12(1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1)
  180 DO 250 JB=1,NB

C   SOLVE K*K TRIANGULAR SYSTEM

          DO 210 I=K,1,-1
              J=MIN(I+1,N)
  210         B(I,JB)=(B(I,JB)-DDOT(K-I,A(I,J),MDA,B(J,JB),1))/A(I,I)

C   COMPLETE SOLUTION VECTOR

          IF(K.EQ.N)                  GOTO 240
          DO 220 J=KP1,N
  220         B(J,JB)=ZERO
          DO 230 I=1,K
  230         CALL H12(2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1,MDB,1)

C   REORDER SOLUTION ACCORDING TO PREVIOUS COLUMN INTERCHANGES

  240     DO 250 J=LDIAG,1,-1
              IF(IP(J).EQ.J)          GOTO 250
              L=IP(J)
              TMP=B(L,JB)
              B(L,JB)=B(J,JB)
              B(J,JB)=TMP
  250 CONTINUE
  270 KRANK=K
      END


       INTEGER SEED
       DATA SEED/3274927/
       EXACT=4.*ATAN(1.)

20     PRINT *, ' Enter number of points (0 to stop)'
       READ *, N
       IF (N .EQ. 0) STOP

       ICOUNT=0
       DO 10 IX=1,N
          X=RAN(SEED)
          Y=RAN(SEED)
          IF ((X**2+Y**2) .LE. 1.) ICOUNT=ICOUNT+1
10     CONTINUE
       PI4=REAL(ICOUNT)/N
       SIGMA=SQRT(PI4*(1.-PI4)/N)
       PRINT *,' pi = ', 4*PI4,' +- ',4*SIGMA,'   error = ',EXACT-4*PI4

       GOTO 20
       END


! { dg-do compile }
! { dg-options "-O2 -fdump-tree-fre" }

subroutine  eval(foo1,foo2,foo3,foo4,x,n,nnd)
  implicit real*8 (a-h,o-z)
  dimension foo3(n),foo4(n),x(nnd)
  nw=0
  foo3(1)=foo2*foo4(1)
  do i=2,n
    foo3(i)=foo2*foo4(i)
    do  j=1,i-1
      temp=0.0d0
      jmini=j-i
      do  k=i,nnd,n
        temp=temp+(x(k)-x(k+jmini))**2
      end do
      temp = sqrt(temp+foo1)
      foo3(i)=foo3(i)+temp*foo4(j)
      foo3(j)=foo3(j)+temp*foo4(i)
    end do
  end do
end subroutine eval

! There should be only one load from n left

! { dg-final { scan-tree-dump-times "\\*n_" 1 "fre" } }
! { dg-final { cleanup-tree-dump "fre" } }


module flut

    implicit none

    double precision, allocatable, dimension(:) :: lut
    double precision :: lut_delta
    double precision :: lut_inv_delta
    double precision :: lut_dmin

contains

    subroutine initialize_lut(dmin, dmax, steps)

    implicit none

    double precision, intent(in) :: dmax
    double precision, intent(in) :: dmin
    integer, intent(in) :: steps

    integer :: i

    double precision :: x0

    lut_delta =  (dmax - dmin) / steps
    lut_inv_delta =  steps / (dmax - dmin)
    lut_dmin = dmin

    allocate(lut(steps))

    !$OMP PARALLEL DO
    do i = 1, steps
        lut(i) = exp(lut_dmin + (i - 1) * lut_delta)

        ! write (*,*) i, dmin + (i - 1) * lut_delta, lut(i)
    enddo
    !$OMP END PARALLEL DO

    end subroutine initialize_lut

    function exp_lut(x) result(e)

        implicit none

        double precision, intent(in) :: x

        double precision :: x_lut
        integer :: x_floor

        double precision :: e

        x_lut = (x - lut_dmin) * lut_inv_delta
        x_floor = floor(x_lut) + 1

        e = lut(x_floor) - (lut(x_floor + 1) - lut(x_floor)) * (x_lut - x_floor)

    end function exp_lut

    subroutine free_lut()

        implicit none

        deallocate(lut)
    end subroutine free_lut

end module flut

program example

    use flut, only: initialize_lut, exp_lut, free_lut

    implicit none

    double precision, parameter :: dmin = -10.0d0
    double precision, parameter :: dmax = 0.0d0
    integer, parameter :: steps = 1e8

    double precision :: x0, e

    call initialize_lut(dmin, dmax, steps)

    call random_seed()

    call random_number(x0)

    x0 = x0 * (dmax - dmin) + dmin

    e = exp_lut(x0)

    write(*,*) "x0          =", x0
    write(*,*) "EXP(x0)     =", exp(x0), e
    write(*,*) "EXP_LUT(x0) =", e
    write(*,*) "DIFF        =", exp(x0) - e
    write(*,*) "RATIO       =", exp(x0) / e

    call free_lut()

end program example


! Compiling with IBM XLF with -O2 works.  Compiling with -O3 causes an incorrect answer.

  module array_max
  USE iso_c_binding
  implicit none

! Holds an index location of an array, and value at that location
  TYPE loc_and_value_type
     REAL(c_double) :: val = -1.0D100
     INTEGER(c_int), DIMENSION(3) :: index = (/0,0,0/)
  END type loc_and_value_type

  !$omp declare reduction(mymaxloc: loc_and_value_type : omp_out = getmax(omp_in,omp_out) )

  contains

   FUNCTION iMAXLOC(var)
     IMPLICIT NONE
     DOUBLE PRECISION, DIMENSION(:,:,:), intent(in) :: var
     INTEGER, DIMENSION(3) :: iMAXLOC
     INTEGER :: ifunr,jfunr,kfunr
     TYPE(loc_and_value_type) :: max1,max2

     !$omp target teams distribute parallel do collapse(3) reduction(mymaxloc:max1) private(max2)
     do kfunr=1,size(var,3)
        do jfunr=1,size(var,2)
           do ifunr=1,size(var,1)
              max2%val = var(ifunr,jfunr,kfunr)
              max2%index = (/ifunr,jfunr,kfunr/)
              max1 = getmax(max2,max1)
           end do
        end do
     end do
     !$omp end target teams distribute parallel do
     iMAXLOC = max1%index
   END FUNCTION iMAXLOC

   FUNCTION getmax(max1,max2)
     IMPLICIT NONE
     !$omp declare target
     type(loc_and_value_type), INTENT(IN) :: max1,max2
     TYPE(loc_and_value_type) :: getmax
     if (max2%val > max1%val) then
        getmax%val   = max2%val
        getmax%index = max2%index
     else
        getmax%val   = max1%val
        getmax%index = max1%index
     end if
   END FUNCTION getmax

   FUNCTION iMAXVAL(var)
     IMPLICIT NONE
     DOUBLE PRECISION, DIMENSION(:,:,:), intent(in) :: var
     DOUBLE PRECISION :: iMAXVAL
     INTEGER :: ifunr,jfunr,kfunr
     iMAXVAL = -1.0D100
     !$omp target teams distribute parallel do collapse(3) reduction(max:iMAXVAL)
     do kfunr=1,size(var,3)
        do jfunr=1,size(var,2)
           do ifunr=1,size(var,1)
              iMAXVAL = MAX(iMAXVAL, var(ifunr,jfunr,kfunr) )
           end do
        end do
     end do
     !$omp end target teams distribute parallel do
   END FUNCTION iMAXVAL

  end module array_max

  program test_max
    USE iso_c_binding
    use array_max, only : imaxloc,imaxval
    implicit none

    real(kind=8), dimension(100,100,100) :: v,w
    real(kind=8) :: vmax=-100.0_8
    integer :: i,j,k,lmax(3)

	 ! Populate array with random numbers.
    call random_number(v)

	 ! Init to zero
    w = 0.0_8

    ! Check locations and values on CPU using intrinsics.
    vmax = maxval(v)
    lmax = maxloc(v)
    print *,'fortran intrinsics on CPU:'
    print *,'cpu max',vmax,'at',lmax

    ! Check locations and values using custom openmp reduction function.
    vmax = -100.0_8
    lmax = -1

    !$omp target data map(to:v) map(alloc:w)

    !$omp target teams distribute parallel do collapse(3)
    do k=1,100 ; do j=1,100 ; do i=1,100
      w(i,j,k) = v(i,j,k)  ! on target
    end do ; end do ; end do
    !$omp end target teams distribute parallel do

	 ! Zero out the host array version, make sure nothing is operating on this array.
    w = 0.0_8

    vmax = iMAXVAL(w)
    lmax = iMAXLOC(w)
    print *, "extrinsics on GPU, first call:"
    print *,'gpu max',vmax,'at',lmax

    vmax = iMAXVAL(w)
    lmax = iMAXLOC(w)
    print *, "extrinsics on GPU, second call:"
    print *,'gpu max',vmax,'at',lmax

    vmax = iMAXVAL(w)
    lmax = iMAXLOC(w)
    print *, "extrinsics on GPU, third call:"
    print *,'gpu max',vmax,'at',lmax

    !$omp end target data

  end program test_max


      FUNCTION FDSTRSE(VOID,BMECH1,BMECH2,BMECH3)
      REAL::FDSTRSE,BMECH1,TMP,VOID,BMECH2,BMECH3,FSTRSEL,DFSTRSEL
C CHANGE RECORD
C  ADDED STANDARD EXPONENTIAL FORM CONSTITUTIVE RELATIONSHIP
C
C
C **  FDSTRSE IS COMPRESSION LENGTH SCALE
C        STRESS WITH RESPECT TO VOID RATIO
C
      IF(BMECH1.GT.0.0)THEN
        TMP=-(VOID-BMECH2)/BMECH3
        TMP=-(VOID-BMECH2)/BMECH3
        FDSTRSE=(BMECH1/BMECH3)*EXP(TMP)
      ELSE
C
C        FDSTRSEL=-0.00835084*(VOID**3)+0.207061*(VOID**2)
C
        FSTRSEL=-0.0147351*(VOID**3)+0.311854*(VOID**2)
     &      -2.96371*VOID+7.34698
        DFSTRSEL=-0.0442053*(VOID**2)+0.623708*VOID
     &      -2.96371
        FDSTRSE=DFSTRSEL*EXP(FSTRSEL)
      END IF
      RETURN
      END


C****************************************************************
C Program BUTTERW
C Applies a Butterworth filter to a spectrum, to reduce
C oscillations during inverse Fourier Transformation
C
C JLP
C Version: 06-02-90
C****************************************************************
	PROGRAM BUTTERW
	PARAMETER(IDIM=256)
	CHARACTER NAME*40,COMMENTS*80
	REAL IN(IDIM,IDIM),OUT(IDIM,IDIM)

C Format of the files:
	PRINT *,' WARNING: all the files should not have odd',
     1	' numbers for NX and NY (size in X and Y)'
	CALL JLP_INQUIFMT

C Input of the squared modulus:
	WRITE(6,37)
37	FORMAT(' Applies Butterworth filter,',/,
     1	' Filter(f)= 1/(1+(f/fc)**2K)',/,
     1	' Cut Frequency fc (in pixel units), and',
     1	' order K (3 is not bad) :')
	READ(5,*) FC,KK

	WRITE(6,38)
38	FORMAT(' (The Fourier images are supposed to be',
     1	' centered in the frame)')
	NAME=' '
	CALL JLP_READIMAG(IN,NX,NY,IDIM,NAME,COMMENTS)

	CALL BUTTERWORTH(IN,OUT,NX,NY,IDIM,FC,KK)

	WRITE(COMMENTS,11) FC,KK,NAME(1:15)
11	FORMAT(' Butterworth ',F9.2,I3,' of:',A15)
	NAME=' '
	CALL JLP_WRITEIMAG(OUT,NX,NY,IDIM,NAME,COMMENTS)

	CALL JLP_END
	END

C*******************************************************************
C BUTTERWORTH
C
C*******************************************************************
	SUBROUTINE BUTTERWORTH(IN,OUT,NX,NY,IDIM,FC,KK)
	INTEGER NX,NY,IDIM,IXC,IYC,KK,KK2
	REAL IN(IDIM,*),OUT(IDIM,*),FC

C Center:
	IXC=(NX/2)+1
	IYC=(NY/2)+1

C Main loop:
	KK2=2*KK
	DO 91 J=1,NY
	  DJ=IYC-J
	  DO 92 I=1,NX
	    DI=IXC-I
	    FF=SQRT(DJ*DJ+DI*DI)
	    OUT(I,J)=IN(I,J)/(1.+(FF/FC)**KK2)
92	  CONTINUE
91	CONTINUE

	RETURN
	END


c***************************************************************************

      subroutine svd(matq,matu,matv,cov,w,p,b,ndef,sig,ic,m,n,mm,nn,toler,jc
     1              ,ssq,res,residuals)
c-----------------------------------------------------------------------
c svd() uses singular-value-decomposition to calculate the least-squares
c solution p to an overdetermined system of linear equations with
c coefficient matrix q, which includes multiple right hand side vectors packed
c side by side into the matrix b.
c
c Much of the api for this routine was based on one by j. cherniawsky, august 1997,
c but some of it (particularly the contents of matq) are now quite different.
c The code basically wraps calls to lapack, which needs to be linked. Prior code was
c based on Numerical Recipes which has licensing issues (and isn't as good anyway).
c
c there are two ways to use svd:
c 1 given an overdetermined system, svd will orthogonalize
c   a and b and produce the least-squares solution.
c 2 given an orthogonalized a (i.e. output from 1),
c   svd will orthogonalize b with respect to a and produce
c   the least-squares solution. this allows the use of
c   multiple r.h.s. without reorthogonalizing a.
c
c No testing has been performed yet for the case ic = 2, since the prior code didn't really
c use it and multiple right hand sides can be handled all at once with a larger rhs matrix b of
c side-by-side right hand sides.
c
c This incarnation due to Eli Ateljevich, California Dept Water Resources
c-----------------------------------------------------------------------
      implicit none
      real*8,intent(in)    :: matq(m,n)   !< design matrix of the overdetermined problem
      real*8,intent(inout) :: matu(m,n)   !< u matrix from svd decomposition
      real*8,intent(inout) :: matv(n,n)   !< v matrix from sdv decomposition

      real*8,intent(out) :: cov(n,n)    !< covariance matrix from design matrix
      real*8,intent(out) :: w(nn)      !< an nn-diagonal vector(matrix) of n eigenvalues of q (u)
      real*8,intent(out) :: p(nn,ndef) !< an output array least-squares coefficients
      real*8,intent(in)  :: b(mm,ndef) !< matrix of ndef right hand sides of size mm
      integer            :: ndef       !< number of right hand sides
      real*8,intent(in) ::  sig(mm)   !< measurement error (standard deviation) for the rhs from the calling program (can be set to 1.).
      integer,intent(in)::  ic         !< input code: 1 for fresh orthogonalization or 2 to re-use prior orthogonalization of q part
      integer,intent(in) :: m         !< number of equations in least squares system
      integer,intent(in) :: n         !< number of columns in least squares system
      integer,intent(in) :: mm        !< number of columns of q
      integer,intent(in) :: nn        !< number of rows of q
      real*8,intent(in)  :: toler     !< an input tolerance, for acceptable matrix condition number
      integer,intent(out):: jc       !< output code which is set to the index of 1st dependent column, if such a column is detected. !todo: still true?

      real*8 :: ssq(ndef)      !< sum squared residuals for each rhs
      real*8 :: res(ndef)      !< maximum residual in magnitude for each rhs
      real*8 :: residuals(m,ndef) !< residuals for each rhs

c ======== Locals
      real*8, parameter :: eps = 1.d-10  !< threshold for labeling an singular value "very small" and zeroing it

      real*8 :: resi
      real*8 :: sum
      real*8 :: thresh
      !integer, parameter :: nwt=302 ! make nwt > expected value of nn   !todo: this was only used for wti. why was it needed?
      real*8 :: wmax
      real*8 :: wti(nn)
      integer info,lda, ldu, ldvt, lwork
      integer i,j,k,idef
      real*8  y(n)
      real*8  vt(n,n), work(max(1,3*min(m,n)+max(m,n),5*min(m,n)) )

c =====================================

      ldu=m
      ldvt=n
	lda=mm
	lwork=max(1,3*min(m,n)+max(m,n),5*min(m,n))

      jc=0

c no need to solve if only rhs has changed
      if(ic.eq.2) go to 10

c compute svd decomposition of matu(=a), with a being replaced by its upper
c matrix u, viz a=u*w*transpose(v), and vector w is output of a diagonal
c matrix of singular values w(i), i=1,n.
c      call dsvdcmp(matu,m,n,mm,nn,w,matv)

      matu = matq(1:m,1:n)
      call dgesvd( 'O', 'A', M, N, matu, mm, w, matu, LDU, VT, LDVT,
     $                   WORK, LWORK, INFO )
      do i = 1,n
        do j = 1,n
           matv(i,j) = VT(j,i)
        end do
      end do

c check for small singular values
      wmax=0.
      do j=1,n
        if(w(j).gt.wmax) wmax=w(j)
      enddo
      thresh=toler*wmax
      do j=1,n
        if(w(j).lt.thresh) then
          w(j)=0.d0
          if(jc.lt.1) jc=j
        endif
      enddo

c compute summation weights (wti, used below)
  10  do j=1,n
        wti(j)=0.d0
        if(w(j).gt.eps) then
c         wti(j)=sig(j)*sig(j)/(w(j)*w(j))
          wti(j)=1.d0/(w(j)*w(j))
        endif
      enddo
c use back-substitution to compute the solution p(i), i=1,n
c     ! need to filter columns where w < thresh
      do idef=1,ndef
        call dgemv('T',m,n,1.d0,matu,m,b(:,idef),1,0.d0,y,1)
        y = y/w
        call dgemv('T',n,n,1.d0,vt,n,y,1,0.d0,p(1,idef),1)
      end do

c compute chisq (=ssq) and the largest residual (res)
      ssq=0.d0
      res=0.d0
      do idef=1,ndef
        do i=1,m
          sum=0.d0
          do j=1,n
            sum=sum+p(j,idef)*matq(i,j)
          enddo
          resi=b(i,idef)-sum
	    residuals(i,idef)=resi
          res(idef)=max(res(idef),abs(resi))
          ssq(idef)=ssq(idef)+resi**2
      end do
      end do
c compute variances, covariances, these may need to be given dimension
c of b(i), e.g., using sig(i), but this is better done after return to main
      do i=1,n
        do j=1,i
          sum=0.d0
          do k=1,n
            sum=sum+matv(i,k)*matv(j,k)*wti(k)
          enddo
          cov(i,j)=sum
          cov(j,i)=sum
        enddo
      enddo
      return
      end subroutine


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE ARCY (XCEN, YCEN, THETA1, THETA2, XK, XA, X, YTRY, ERR)
C***********************************************************************

C  SUBROUTINE ARCY = ITERATIVELY SOLVES THE LOGARITHMIC SPIRAL PROBLEM
C                    TO DETERMINE A Y VALUE GIVEN AN X THAT INTERSECTS
C                    THE ARC

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

      LOGICAL ERR

C  START WITH 10 INCREMENTS, EACH PASS INCREMENTS DECREASE TEN FOLD

      ANGINC = (THETA2 - THETA1) * .05
      ANG = THETA1
      F1 = SPIRAL (XA, XK, X, XCEN, YCEN, ANG)
      IF (F1 .EQ. 0.0) THEN
         THETA = ANG
         GO TO 110
      END IF
      ANG2 = ANG + ANGINC
  100 CONTINUE
      F2 = SPIRAL (XA, XK, X, XCEN, YCEN, ANG2)
      IF (F2 .EQ. 0.0) THEN
         THETA = ANG2
      ELSE IF (F1*F2 .LT. 0.0) THEN
         THETA = SOLVE(XA, XK, X, XCEN, YCEN, ANG, ANG2)
      ELSE
         ANG = ANG2
         ANG2 = ANG2 + ANGINC
         IF (ANG2 .LE. THETA2) GO TO 100
         ERR = .TRUE.
         GO TO 120
      END IF

  110 CONTINUE
      YTRY = (XA * EXP(XK * THETA)) * SIN(THETA) + YCEN

  120 CONTINUE

C  FIND THE SECOND ROOT IF THE FIRST ONE HAS BEEN LOCATED

      IF(.NOT.ERR)THEN
         ANG=THETA+ANGINC
         F1 = SPIRAL (XA, XK, X, XCEN, YCEN, ANG)
         F2 = SPIRAL (XA, XK, X, XCEN, YCEN, THETA2)
         IF (F1 .EQ. 0.0) THEN
            THETA = ANG
         ELSEIF (F2 .EQ. 0.0) THEN
            THETA = THETA2
         ELSE IF (F1*F2 .LT. 0.0) THEN
            THETA = SOLVE(XA, XK, X, XCEN, YCEN, ANG, THETA2)
         ELSE
            GO TO 130
         END IF
      END IF

      YTRY2 = (XA * EXP(XK * THETA)) * SIN(THETA) + YCEN
      YTRY = MAX(YTRY,YTRY2)
  130 CONTINUE
      RETURN

      END


      DOUBLE PRECISION FUNCTION MA02MD( NORM, UPLO, N, A, LDA, DWORK )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the value of the one norm, or the Frobenius norm, or
C     the infinity norm, or the element of largest absolute value
C     of a real skew-symmetric matrix.
C
C     Note that for this kind of matrices the infinity norm is equal
C     to the one norm.
C
C     FUNCTION VALUE
C
C     MA02MD  DOUBLE PRECISION
C             The computed norm.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     NORM    CHARACTER*1
C             Specifies the value to be returned in MA02MD:
C             = '1' or 'O':  one norm of A;
C             = 'F' or 'E':  Frobenius norm of A;
C             = 'I':         infinity norm of A;
C             = 'M':         max(abs(A(i,j)).
C
C     UPLO    CHARACTER*1
C             Specifies whether the upper or lower triangular part of
C             the skew-symmetric matrix A is to be referenced.
C             = 'U':  Upper triangular part of A is referenced;
C             = 'L':  Lower triangular part of A is referenced.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.  When N = 0, MA02MD is
C             set to zero.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The skew-symmetric matrix A.  If UPLO = 'U', the leading
C             N-by-N strictly upper triangular part of A contains the
C             strictly upper triangular part of the matrix A, and the
C             lower triangular part of A is not referenced.
C             If UPLO = 'L', the leading N-by-N strictly lower
C             triangular part of A contains the strictly lower
C             triangular part of the matrix A, and the upper triangular
C             part of A is not referenced.
C             The diagonal of A need not be set to zero.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (MAX(1,LDWORK)),
C             where LDWORK >= N when NORM = 'I' or '1' or 'O';
C             otherwise, DWORK is not referenced.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Oct. 2015.
C     Based on LAPACK reference routine DLANSY.
C
C     REVISIONS
C
C     V. Sima, Jan. 2016.
C
C     KEYWORDS
C
C     Elementary matrix operations, skew-symmetric matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, TWO, ZERO
      PARAMETER          ( ONE = 1.0D+0, TWO = 2.0D+0, ZERO = 0.0D+0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          NORM, UPLO
      INTEGER            LDA, N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), DWORK( * )
C     ..
C     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   ABSA, SCALE, SUM, VALUE
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DLASSQ
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, SQRT
C     ..
C     .. Executable Statements ..
C
      IF( N.LE.1 ) THEN
         VALUE = ZERO
      ELSE IF( LSAME( NORM, 'M' ) ) THEN
C
C        Find max(abs(A(i,j))).
C
         VALUE = ZERO
         IF( LSAME( UPLO, 'U' ) ) THEN
            DO 20 J = 2, N
               DO 10 I = 1, J-1
                  VALUE = MAX( VALUE, ABS( A( I, J ) ) )
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40 J = 1, N-1
               DO 30 I = J+1, N
                  VALUE = MAX( VALUE, ABS( A( I, J ) ) )
   30          CONTINUE
   40       CONTINUE
         END IF
C
      ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
     $         ( NORM.EQ.'1' ) ) THEN
C
C        Find normI(A) ( = norm1(A), since A is skew-symmetric).
C
         VALUE = ZERO
         IF( LSAME( UPLO, 'U' ) ) THEN
            DWORK( 1 ) = ZERO
            DO 60 J = 2, N
               SUM = ZERO
               DO 50 I = 1, J-1
                  ABSA = ABS( A( I, J ) )
                  SUM  = SUM + ABSA
                  DWORK( I ) = DWORK( I ) + ABSA
   50          CONTINUE
               DWORK( J ) = SUM
   60       CONTINUE
            DO 70 I = 1, N
               VALUE = MAX( VALUE, DWORK( I ) )
   70       CONTINUE
         ELSE
            DO 80 I = 1, N
               DWORK( I ) = ZERO
   80       CONTINUE
            DO 100 J = 1, N-1
               SUM = DWORK( J )
               DO 90 I = J+1, N
                  ABSA = ABS( A( I, J ) )
                  SUM  = SUM + ABSA
                  DWORK( I ) = DWORK( I ) + ABSA
   90          CONTINUE
               VALUE = MAX( VALUE, SUM )
  100       CONTINUE
            VALUE = MAX( VALUE, DWORK( N ) )
         END IF
C
      ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
C
C        Find normF(A).
C
         SCALE = ZERO
         SUM   = ONE
         IF( LSAME( UPLO, 'U' ) ) THEN
            DO 110 J = 2, N
               CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
  110       CONTINUE
         ELSE
            DO 120 J = 1, N-1
               CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
  120       CONTINUE
         END IF
         VALUE = SCALE*SQRT( TWO*SUM )
      END IF
C
      MA02MD = VALUE
      RETURN
C
C *** Last line of MA02MD ***
      END


program main

!*****************************************************************************80
!
!! MAIN is the main program for BUFFON_LAPLACE.
!
!  Discussion:
!
!    This program uses MPI to do a Buffon-Laplace simulation in parallel.
!
!    This is an example of an "embarassingly parallel" computation.  Each
!    processor does the same randomized computation, counting "successes",
!    and returning the number of successes to the master process.
!
!    The particular point made by this example is that each process must
!    use a different stream of random numbers, and that this can be done
!    if each process uses a different seed to initialize the random number
!    generator, and that this, in turn, can be done by simply adding the
!    process's rank to a common seed value.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    26 October 2007
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    William Gropp, Ewing Lusk, Anthony Skjellum,
!    Using MPI: Portable Parallel Programming with the
!    Message-Passing Interface,
!    Second Edition,
!    MIT Press, 1999,
!    ISBN: 0262571323.
!
!    Sudarshan Raghunathan,
!    Making a Supercomputer Do What You Want: High Level Tools for
!    Parallel Programming,
!    Computing in Science and Engineering,
!    Volume 8, Number 5, September/October 2006, pages 70-80.
!

  use mo_kind, only: i4, dp
  use mo_ansi_colors, only: color, c_red, c_green

#ifdef __MPI__
#ifdef __NAG__
  implicit none

  include "mpif.h"
#else
  ! use mpi, only: mpi_init, mpi_success, mpi_finalize, mpi_comm_size, mpi_comm_world, &
  !      mpi_comm_rank, mpi_reduce, mpi_integer, mpi_sum

  implicit none

  include "mpif.h"
#endif
#else
  use mo_mpi_stubs, only: mpi_init, mpi_success, mpi_finalize, mpi_comm_size, mpi_comm_world, &
       mpi_comm_rank, mpi_reduce, mpi_integer, mpi_sum

  implicit none
#endif

  real(dp) :: a = 1.0D+00
  real(dp) :: b = 1.0D+00
  integer(i4) :: buffon_laplace_simulate
  integer(i4):: hit_num
  integer(i4):: hit_total
  integer(i4):: ierr
  real(dp) :: l = 1.0D+00
  integer (kind = 4), parameter :: master = 0
  real(dp) :: pdf_estimate
  real(dp), parameter :: pi = 3.141592653589793238462643D+00
  real(dp) :: pi_error
  real(dp) :: pi_estimate
  integer(i4):: process_num
  integer(i4):: process_rank
  integer(i4):: seed
  integer(i4):: trial_num = 100000
  integer(i4):: trial_total
  real(dp) :: random_value
  integer(i4) :: n = 1
!
!  Initialize MPI.
!

  call MPI_Init ( ierr )

  if ( ierr /= MPI_SUCCESS ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'BUFFON_LAPLACE: Warning!'
    write ( *, '(a,i8)' ) '  MPI_INIT returns IERR = ', ierr
    call MPI_Finalize ( ierr )
    stop
  end if
!
!  Get the number of processes.
!
  call MPI_Comm_size ( MPI_COMM_WORLD, process_num, ierr )
!
!  Get the rank of this processor.
!
  call MPI_Comm_rank ( MPI_COMM_WORLD, process_rank, ierr )
!
!  The master process sets the value of the parameters,
!  and broadcasts them.
!
  if ( process_rank == master ) then
#ifdef __MPI__
     write ( *, '(a)' ) 'Using mpi'
#else
     write ( *, '(a)' ) 'Using mo_mpi_stubs'
#endif
  endif

  if ( process_rank == master ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'BUFFON_LAPLACE - Master process:'
    write ( *, '(a)' ) '  FORTRAN90 version'
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  An MPI example program to estimate PI'
    write ( *, '(a)' ) '  using the Buffon-Laplace needle experiment.'
    write ( *, '(a)' ) '  On a grid of cells of  width A and height B,'
    write ( *, '(a)' ) '  a needle of length L is dropped at random.'
    write ( *, '(a)' ) '  We count the number of times it crosses'
    write ( *, '(a)' ) '  at least one grid line, and use this to estimate '
    write ( *, '(a)' ) '  the value of PI.'
    write ( *, '(a)' ) ' '
    write ( *, '(a,i8)' ) '  The number of processes is ', process_num
    write ( *, '(a)' ) ' '
    write ( *, '(a,f14.6)' ) '  Cell width A =    ', a
    write ( *, '(a,f14.6)' ) '  Cell height B =   ', b
    write ( *, '(a,f14.6)' ) '  Needle length L = ', l
  end if
!
!  Each process sets a random number seed.
!
  seed = 123456789 + process_rank * 100
!
!  The process of setting the random number seed in FORTRAN90 is,
!  at least, uniformly specified by the language,
!  but lamentably Byzantine and cumbersome.
!
!  I put all this rigmarole in a subroutine.
!
  call random_initialize ( seed )
!
!  Just to make sure that we're all doing different things, have each
!  process print out its rank, seed value, and a first test random value.
!
  call random_number ( harvest = random_value )

  write ( *, '(2x,i8,2x,i12,2x,g14.6)' ) process_rank, seed, random_value
!
!  Each process now carries out TRIAL_NUM trials, and then
!  sends the value back to the master process.
!
  hit_num = buffon_laplace_simulate ( a, b, l, trial_num )

  call MPI_Reduce ( hit_num, hit_total, n, MPI_INTEGER, MPI_SUM, master, &
    MPI_COMM_WORLD, ierr )
!
!  The master process can now estimate PI.
!
  if ( process_rank == master ) then

    trial_total = trial_num * process_num

    pdf_estimate = real ( hit_total, kind = 8 ) / real ( trial_total, kind = 8 )

    if ( hit_total == 0 ) then

      pi_estimate = huge ( pi_estimate )

    else

      pi_estimate = l * ( 2.0D+00 * ( a + b ) - l ) / ( a * b * pdf_estimate )

    end if

    pi_error = abs ( pi - pi_estimate )

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '    Trials      Hits    Estimated PDF  ' // &
      '     Estimated Pi         Error'
    write ( *, '(a)' ) ' '
    write ( *, '(2x,i8,2x,i8,2x,g20.12,2x,g20.12,2x,g20.12)' ) &
         trial_total, hit_total, pdf_estimate, pi_estimate, pi_error

    if (pi_error < 0.1_dp) then
       write(*,*) 'mo_mpi_stubs ', color('o.k.', c_green)
    else
       write(*,*) 'mo_mpi_stubs ', color('failed!', c_red)
    endif

  end if
!
!  Terminate MPI.
!
  call MPI_Finalize ( ierr )
!
!  Terminate.
!
  if ( process_rank == master ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'BUFFON_LAPLACE - Master process:'
    write ( *, '(a)' ) '  Normal end of execution.'
  end if

end program main

function buffon_laplace_simulate ( a, b, l, trial_num )

!*****************************************************************************80
!
!! BUFFON_LAPLACE_SIMULATE simulates a Buffon-Laplace needle experiment.
!
!  Discussion:
!
!    In the Buffon-Laplace needle experiment, we suppose that the plane has been
!    tiled into a grid of rectangles of width A and height B, and that a
!    needle of length L is dropped "at random" onto this grid.
!
!    We may assume that one end, the "eye" of the needle falls at the point
!    (X1,Y1), taken uniformly at random in the cell [0,A]x[0,B].
!
!    ANGLE, the angle that the needle makes is taken to be uniformly random.
!    The point of the needle, (X2,Y2), therefore lies at
!
!      (X2,Y2) = ( X1+L*cos(ANGLE), Y1+L*sin(ANGLE) )
!
!    The needle will have crossed at least one grid line if any of the
!    following are true:
!
!      X2 <= 0, A <= X2, Y2 <= 0, B <= Y2.
!
!    This routine simulates the tossing of the needle, and returns the number
!    of times that the needle crossed at least one grid line.
!
!    If L is larger than sqrt ( A*A + B*B ), then the needle will
!    cross every time, and the computation is uninteresting.  However, if
!    L is smaller than this limit, then the probability of a crossing on
!    a single trial is
!
!      P(L,A,B) = ( 2 * L * ( A + B ) - L * L ) / ( PI * A * B )
!
!    and therefore, a record of the number of hits for a given number of
!    trials can be used as a very roundabout way of estimating PI.
!    (Particularly roundabout, since we actually will use a good value of
!    PI in order to pick the random angles!)
!
!    Note that this routine will try to generate 5 * TRIAL_NUM random
!    double precision values at one time, using automatic arrays.
!    When I tried this with TRIAL_NUM = 1,000,000, the program failed,
!    because of internal system limits on such arrays.
!
!    Such a problem could be avoided by using a DO loop running through
!    each trial individually, but this tend to run much more slowly than
!    necessary.
!
!    Since this routine invokes the FORTRAN90 random number generator,
!    the user should initialize the random number generator, particularly
!    if it is desired to control whether the sequence is to be varied
!    or repeated.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    26 February 2007
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Sudarshan Raghunathan,
!    Making a Supercomputer Do What You Want: High Level Tools for
!    Parallel Programming,
!    Computing in Science and Engineering,
!    Volume 8, Number 5, September/October 2006, pages 70-80.
!
!  Parameters:
!
!    Input, real(dp) A, B, the horizontal and vertical dimensions
!    of each cell of the grid.  0 <= A, 0 <= B.
!
!    Input, real(dp) L, the length of the needle.
!    0 <= L <= min ( A, B ).
!
!    Input, integer TRIAL_NUM, the number of times the needle is
!    to be dropped onto the grid.
!
!    Output, integer BUFFON_LAPLACE_SIMULATE, the number of times the needle
!    crossed at least one line of the grid of cells.
!
!  Local Parameters:
!
!    Local, integer BATCH_SIZE, specifies the number of trials to be done
!    in a single batch.  Setting BATCH_SIZE to 1 will be very slow.
!    Replacing it by TRIAL_NUM would be fine except that your system
!    may have a limit on the size of automatic arrays.  We have set a default
!    value of 10,000 here which should be large enough to be efficient
!    but small enough not to annoy the system.
!
  use mo_kind, only: i4, dp

  implicit none

  integer(i4), parameter :: batch_size = 10000
  integer(i4) :: trial_num

  real(dp) :: a
  real(dp) :: angle(batch_size)
  real(dp) :: b
  integer(i4) :: batch
  integer(i4) :: buffon_laplace_simulate
  integer(i4) :: hits
  real(dp) :: l
  integer(i4) :: n
  real(dp), parameter :: pi = 3.141592653589793238462643D+00
  real(dp) :: x1(batch_size)
  real(dp) :: x2(batch_size)
  real(dp) :: y1(batch_size)
  real(dp) :: y2(batch_size)

  hits = 0

  do batch = 1, trial_num, batch_size

    n = min ( batch_size, trial_num + 1 - batch )
!
!  Randomly choose the location of the eye of the needle in [0,0]x[A,B],
!  and the angle the needle makes.
!
    call random_number ( harvest = x1(1:n) )
    call random_number ( harvest = y1(1:n) )
    call random_number ( harvest = angle(1:n) )

    x1(1:n) = a * x1(1:n)
    y1(1:n) = b * y1(1:n)
    angle(1:n) = 2.0D+00 * pi * angle(1:n)
!
!  Compute the location of the point of the needle.
!
    x2(1:n) = x1(1:n) + l * cos ( angle(1:n) )
    y2(1:n) = y1(1:n) + l * sin ( angle(1:n) )
!
!  Count the end locations that lie outside the cell.
!
    hits = hits + count (      x2(1:n) <= 0.0 .or. &
                          a <= x2(1:n)        .or. &
                               y2(1:n) <= 0.0 .or. &
                          b <= y2(1:n) )

  end do

  buffon_laplace_simulate = hits

  return
end function buffon_laplace_simulate

subroutine random_initialize ( seed_input )

!*****************************************************************************80
!
!! RANDOM_INITIALIZE initializes the FORTRAN90 random number seed.
!
!  Discussion:
!
!    If you don't initialize the FORTRAN90 random number generator
!    routine RANDOM_NUMBER, which is used by calls like
!
!      call random_number ( harvest = x )
!
!    then its behavior is not specified.  That may be OK for you.  But
!    you may want to be able to force the same sequence to be generated
!    each time, or to force a different sequence.
!
!    To control the sequence of random numbers, you need to set the seed.
!    In FORTRAN90, this is done by calling the RANDOM+SEED routine.
!    You can call it with no arguments, in fact.  But if you call
!    it with no arguments:
!
!      call random_seed ( )
!
!    then its behavior (or more particularly, the behavior of RANDOM_NUMBER)
!    is still not specified.  You might hope that the system will go out
!    and pick a nice random seed for you, but there's no guarantee.
!
!
!    For example, on the DEC ALPHA, if you compile a program that calls
!    RANDOM_NUMBER, then every time you run it, you get the same sequence
!    of "random" values.  If you compile a program that calls RANDOM_SEED
!    with no arguments, and then calls RANDOM_NUMBER, you still get the
!    same sequence each time you run the program.
!
!    In order to actually try to scramble up the random number generator
!    a bit, this routine goes through the tedious process of getting the
!    size of the random number seed, making up values based on the current
!    time, and setting the random number seed.
!
!    Unfortunately, the RANDOM_SEED routine has a very elastic definition.
!    It does not use a single scalar integer SEED.  Instead, it communicates
!    with the user through an integer vector whose size is not specified.
!    You actually have to "ask" the routine to tell you the size of this
!    vector.  Then you can fill up the vector with values to be used to
!    influence the seeding of the random number routine.  The details of
!    how the seed affects the sequence are also unspecified, but the only
!    thing we are reasonably confident about is that specifying the same
!    seed should result in the same sequence, and specifying different
!    seeds should result in different sequences!
!
!    I assume this is far more than you wanted to know.  (It's certainly
!    more than I wanted to know!)
!
!    The argument SEED is an input quantity only, so it is legal
!    to type
!
!      call random_initialize ( 0 )
!
!    or
!
!      call random_initialize ( 18867 )
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    21 February 2006
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer SEED_INPUT, the user's "suggestion" for a seed.
!    However, if the input value is 0, the routine will come up with
!    its own "suggestion", based on the system clock.
!
  use mo_kind, only: i4, dp

  implicit none

  integer(i4) :: count
  integer(i4) :: count_max
  integer(i4) :: count_rate
  logical, parameter :: debug = .false.
  integer(i4) :: i
  integer(i4) :: seed
  integer(i4) :: seed_input
  integer(i4), allocatable :: seed_vector(:)
  integer(i4) :: seed_size
  real(dp) :: t
  integer(i4), parameter :: warm_up = 100

  seed = seed_input
!
!  Initialize the random seed routine.
!
  call random_seed ( )
!
!  Determine the size of the random number seed vector.
!
  call random_seed ( size = seed_size )
!
!  Allocate a vector of the right size to be used as a random seed.
!
  allocate ( seed_vector(seed_size) )
!
!  If the user supplied a SEED value, use that.
!
!  Otherwise, use the system clock value to make up a value that is
!  likely to change based on when this routine is called.
!
  if ( seed /= 0 ) then

    if ( debug ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'RANDOM_INITIALIZE'
      write ( *, '(a,i20)' ) '  Initialize RANDOM_NUMBER, user SEED = ', seed
    end if

  else

    call system_clock ( count, count_rate, count_max )

    seed = count

    if ( debug ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'RANDOM_INITIALIZE'
      write ( *, '(a,i20)' ) '  Initialize RANDOM_NUMBER, arbitrary SEED = ', &
        seed
    end if

  end if
!
!  Set the seed vector.  We don't know the significance of the
!  individual entries of the internal seed vector, so we'll just set
!  all entries to SEED.
!
  seed_vector(1:seed_size) = seed
!
!  Now call RANDOM_SEED, and tell it to use this seed vector.
!
  call random_seed ( put = seed_vector(1:seed_size) )
!
!  Free up the seed space.
!
  deallocate ( seed_vector )
!
!  Call the random number routine a bunch of times just to "warm it up".
!
  do i = 1, warm_up
    call random_number ( harvest = t )
  end do

  return
end subroutine random_initialize


program main

use test, only: test_value
use io, only: stdout

use random

implicit none

integer :: i
double precision :: dp1, dp2
real :: real1, real2
complex :: c1 !, c2
complex (kind=8) :: dc1 !, dc2

! timeseed()
iseed = timeseed()
if (iseed.gt.0.and.iseed.lt.240000) then
    iseed = 1
else
    iseed = 0
endif
call test_value(iseed,1,'timeseed()')

! ran0()
iseed = -123456
dp1 = ran0(iseed)
call test_value(dp1,0.81047654151916504d0,'ran0(): value')
call test_value(iseed,123457,'ran0(): iseed')

! c4_normal_01
iseed = 98498171
c1 = c4_normal_01(iseed)
call test_value(c1,(-0.474812567,-0.152586848),'c4_normal_01()')

! c8_normal_01
iseed = 552792940
dc1 = c8_normal_01(iseed)
call test_value(dc1,(-0.98438105957821054d0,-1.0320012536812111d0),'c8_normal_01()')

! i4_normal_ab
iseed = 95061600
real1 = 10.0 ! mean
real2 = 6.0  ! standard deviation
i = i4_normal_ab(real1,real2,iseed)
call test_value(i,9,'i4_normal_ab(): value')
call test_value(iseed,1291390176,'i4_normal_ab(): iseed')

! i8_normal_ab

! r4_normal_01
iseed = 726391
real1 = r4_normal_01(iseed)
call test_value(real1,0.577163041,'r4_normal_01(): value')
call test_value(iseed,1858576450,'r4_normal_01(): iseed')

! r4_normal_ab
iseed = 9347
real1 = 4.0 ! mean
real2 = 1.0  ! standard deviation
real1 = r4_normal_ab(real1,real2,iseed)
call test_value(real1,1.72496796,'r4_normal_ab(): value')
call test_value(iseed,1038750240,'r4_normal_ab(): iseed')

! r4_uniform_01
iseed = 2384323
real1 = r4_uniform_01(iseed)
call test_value(real1,0.660592258,'r4_uniform_01(): value')
call test_value(iseed,1418611015,'r4_uniform_01(): iseed')

! r4vec_uniform_01
! r4vec_normal_ab

! r8_normal_01
iseed = 23823
dp1 = r8_normal_01(iseed)
call test_value(dp1,-1.2982174417976360d0,'r8_normal_01(): value')
call test_value(iseed,1341590876,'r8_normal_01(): iseed')

! r8_normal_ab
iseed = 92762192
dp1 = -45.0d0
dp2 = 7.0d0
dp1 = r8_normal_ab(dp1,dp2,iseed)
call test_value(dp1,-45.869090907966878d0,'r8_normal_ab(): value')
call test_value(iseed,1200425557,'r8_normal_ab(): iseed')

! r8_uniform_01
iseed = 142
dp1 = r8_uniform_01(iseed)
call test_value(dp1,1.1113444347797751d-3,'r8_uniform_01(): value')
call test_value(iseed,2386594,'r8_uniform_01(): iseed')

! r8mat_normal_01
! r8mat_normal_ab
! r8vec_normal_01
! r8vec_normal_ab
! r8vec_uniform_01

write(stdout,*) 'random_module unit test passed'

end


program test_spread ! demonstrate SPREAD intrinsic
implicit none
integer :: ivec(2) = [4,7], ident(2,2) = &
  reshape([1,0,0,1],[2,2]) ! 2x2 identity matrix
call display(spread(ivec,dim=1,ncopies=3))
! copies rows since dim = 1
!  4 7
!  4 7
!  4 7
call display(spread(ivec,dim=2,ncopies=3))
! copies columns since dim = 2
!  4 4 4
!  7 7 7
call display(ident + spread(ivec,dim=2,ncopies=2))
! add column copies of ivec to identity matrix
!  5 4 = 1 0 + 4 4
!  7 8   0 1   7 7
contains
!
subroutine display(mat) ! print matrix by rows
integer, intent(in) :: mat(:,:)
integer             :: i
do i=1,size(mat,1)
   print "(*(i2))", mat(i,:)
end do
print*
end subroutine display
end program test_spread


!********************************************************************************
!   BACKERR_WELLCOND: Compare the backward error of FPML, FPML-QUAD, and FPML-CP.
!   Author: Thomas R. Cameron, Penn State Erie The Behrend College
!   Last Modified: 31 July 2020
!********************************************************************************
program backerr_wellcond
    use fpml, only : main
	use fpml_comp, only: main_comp
	use fpml_quad, only: qp, main_quad
    use mproutines
    implicit none
    ! testing variables
    integer                                     :: deg, it, j, startDegree, endDegree, itnum, clock_rate, clock_start, clock_stop
    real(kind=dp), allocatable                  :: results(:,:)
    ! FPML variables
    integer, parameter                          :: itmax = 30
    integer, allocatable                        :: conv(:)
    real(kind=dp), allocatable                  :: berr(:), cond(:)
	real(kind=qp), allocatable					:: berr_quad(:), cond_quad(:)
    complex(kind=dp), allocatable               :: p(:), roots(:)
	complex(kind=qp), allocatable				:: p_quad(:), roots_quad(:)

    ! Test: random coefficients
    startDegree=50
    endDegree=600
    itnum=32
    call init_random_seed()
    open(unit=1,file="data_files/backerr_wellcond_rand.dat")
    write(1,'(A)') 'Degree, FPML-time, FPML-err, FPML-Quad-time, FPML-Quad-err, FPML-Comp-time, FPML-Comp-err'
    allocate(results(itnum,6))
    deg = startDegree
    do while(deg<=endDegree)
        write(1,'(I10,A)', advance='no') deg, ','
        allocate(p(deg+1), roots(deg), berr(deg), cond(deg), conv(deg))
		allocate(p_quad(deg+1), roots_quad(deg), berr_quad(deg), cond_quad(deg))
        do it=1,itnum
            ! complex polynomial with random coefficients
            call cmplx_rand(deg+1,p)
            ! FPML, No Polish
            call system_clock(count_rate=clock_rate)
            call system_clock(count=clock_start)
            call main(p, deg, roots, berr, cond, conv, itmax)
            call system_clock(count=clock_stop)
            results(it,1)=dble(clock_stop-clock_start)/dble(clock_rate)
            results(it,2) = error(p, roots, deg)
            ! FPML, Quad Precision
			p_quad = p
            call system_clock(count_rate=clock_rate)
            call system_clock(count=clock_start)
            call main_quad(p_quad, deg, roots_quad, berr_quad, cond_quad, conv, itmax)
            call system_clock(count=clock_stop)
            results(it,3)=dble(clock_stop-clock_start)/dble(clock_rate)
			roots = roots_quad
            results(it,4) = error(p, roots, deg)
            ! FPML, Compensated Laguerre Polish
            call system_clock(count_rate=clock_rate)
            call system_clock(count=clock_start)
            call main_comp(p, deg, roots, itmax)
            call system_clock(count=clock_stop)
            results(it,5)=dble(clock_stop-clock_start)/dble(clock_rate)
            results(it,6) = error(p, roots, deg)
        end do
        deallocate(p, roots, berr, cond, conv)
		deallocate(p_quad, roots_quad, berr_quad, cond_quad)
        ! write results to file
        write(1,'(ES15.2,A)', advance='no') sum(results(1:itnum,1))/itnum, ','
        write(1,'(ES15.2,A)', advance='no') sum(results(1:itnum,2))/itnum, ','
        write(1,'(ES15.2,A)', advance='no') sum(results(1:itnum,3))/itnum, ','
        write(1,'(ES15.2,A)', advance='no') sum(results(1:itnum,4))/itnum, ','
        write(1,'(ES15.2,A)', advance='no') sum(results(1:itnum,5))/itnum, ','
        write(1,'(ES15.2)') sum(results(1:itnum,6))/itnum
        ! update deg
        deg = deg + 10
    end do
    ! deallocate results and close file
    deallocate(results)
    close(1)

    ! Test: natural number coefficients
    startDegree=50
    endDegree=600
    itnum=32
    open(unit=1,file="data_files/backerr_wellcond_nat.dat")
    write(1,'(A)') 'Degree, FPML-time, FPML-err, FPML-Quad-time, FPML-Quad-err, FPML-Comp-time, FPML-Comp-err'
    allocate(results(itnum,6))
    deg = startDegree
    do while(deg<=endDegree)
        write(1,'(I10,A)', advance='no') deg, ', '
        allocate(p(deg+1), roots(deg), berr(deg), cond(deg), conv(deg))
		allocate(p_quad(deg+1), roots_quad(deg), berr_quad(deg), cond_quad(deg))
        do it=1,itnum
            ! polynomial with natural number coefficients
            p = (/ (j, j=1,deg+1)/)
            ! FPML, No Polish
            call system_clock(count_rate=clock_rate)
            call system_clock(count=clock_start)
            call main(p, deg, roots, berr, cond, conv, itmax)
            call system_clock(count=clock_stop)
            results(it,1)=dble(clock_stop-clock_start)/dble(clock_rate)
            results(it,2) = error(p, roots, deg)
            ! FPML, Quad Precision
			p_quad = p
            call system_clock(count_rate=clock_rate)
            call system_clock(count=clock_start)
            call main_quad(p_quad, deg, roots_quad, berr_quad, cond_quad, conv, itmax)
            call system_clock(count=clock_stop)
            results(it,3)=dble(clock_stop-clock_start)/dble(clock_rate)
			roots = roots_quad
            results(it,4) = error(p, roots, deg)
            ! FPML, Compensated Laguerre Polish
            call system_clock(count_rate=clock_rate)
            call system_clock(count=clock_start)
            call main_comp(p, deg, roots, itmax)
            call system_clock(count=clock_stop)
            results(it,5)=dble(clock_stop-clock_start)/dble(clock_rate)
            results(it,6) = error(p, roots, deg)
        end do
        deallocate(p, roots, berr, cond, conv)
		deallocate(p_quad, roots_quad, berr_quad, cond_quad)
        ! write results to file
        write(1,'(ES15.2,A)', advance='no') sum(results(1:itnum,1))/itnum, ','
        write(1,'(ES15.2,A)', advance='no') sum(results(1:itnum,2))/itnum, ','
        write(1,'(ES15.2,A)', advance='no') sum(results(1:itnum,3))/itnum, ','
        write(1,'(ES15.2,A)', advance='no') sum(results(1:itnum,4))/itnum, ','
        write(1,'(ES15.2,A)', advance='no') sum(results(1:itnum,5))/itnum, ','
        write(1,'(ES15.2)') sum(results(1:itnum,6))/itnum
        ! update deg
        deg = deg + 10
    end do
    ! deallocate results and close file
    deallocate(results)
    close(1)

contains

    !************************************************
    !                   cmplx_rand                  *
    !************************************************
    ! Creates array of random complex numbers of
    ! size n. Each complex number has real and
    ! imaginary parts uniformly distributed on (-1,1).
    !************************************************
    subroutine cmplx_rand(n,x)
        implicit none
        ! argument variables
        integer, intent(in)             :: n
        complex(kind=dp), intent(out)   :: x(:)
        ! local variables
        integer                         :: k
        real(kind=dp)                   :: r1, r2

        ! main
        do k=1,n
            call random_number(r1)
            call random_number(r2)
            x(k) = cmplx(-1+2*r1,-1+2*r2,kind=dp)
        end do
    end subroutine cmplx_rand
    !************************************************
    !                   error                       *
    !************************************************
    ! Computes the backward error of the polynomial
    ! with respect to the 1-norm.
    !************************************************
    function error(p, roots, deg) result(err)
        implicit none
        ! argument variables
        integer, intent(in)             :: deg
        complex(kind=dp), intent(in)    :: p(:), roots(:)
        ! local variables
        integer                         :: k
        real(kind=dp)                   :: err, rho
        complex(kind=dp)                :: alpha(deg+1)

        alpha(deg+1) = p(deg+1)
        call rootCoeffCplx(deg, roots, alpha)
        rho = maxval((/ (abs(p(k)), k=1,deg+1)/))
        err = maxval((/ (abs(alpha(k)-p(k))/rho, k=1,deg+1)/))
        return
    end function error
    !************************************************
    !                   init_random_seed            *
    !************************************************
    ! Initiate random seed using system_clock. This
    ! seed is then available for the random number
    ! generator in random_number for the life of
    ! the program.
    !************************************************
    subroutine init_random_seed()
        implicit none
        ! local variables
        integer                             :: i, n, clock
        integer, dimension(:), allocatable  :: seed
        ! intrinsic subroutines
        intrinsic                           :: random_seed, system_clock

        ! main
        call random_seed(size = n)
        allocate(seed(n))

        call system_clock(count = clock)
        seed = clock + 37 * (/ (i - 1, i = 1,n) /)
        call random_seed(put = seed)

        deallocate(seed)
    end subroutine init_random_seed
end program backerr_wellcond


! { dg-do run }
! { dg-options "-std=f2008 -fall-intrinsics" }
!

integer :: p, r, rdx

! Compile-time version

if (selected_real_kind(radix=2) /= 4) call should_not_fail()
if (selected_real_kind(radix=4) /= -5) call should_not_fail()
if (selected_real_kind(precision(0.0),range(0.0),radix(0.0)) /= kind(0.0)) &
  call should_not_fail()
if (selected_real_kind(precision(0.0d0),range(0.0d0),radix(0.0d0)) /= kind(0.0d0)) &
  call should_not_fail()

! Run-time version

rdx = 2
if (selected_real_kind(radix=rdx) /= 4) call abort()
rdx = 4
if (selected_real_kind(radix=rdx) /= -5) call abort()

rdx = radix(0.0)
p = precision(0.0)
r = range(0.0)
if (selected_real_kind(p,r,rdx) /= kind(0.0)) call abort()

rdx = radix(0.0d0)
p = precision(0.0d0)
r = range(0.0d0)
if (selected_real_kind(p,r,rdx) /= kind(0.0d0)) call abort()
end


SUBROUTINE clawpack5_qinit(meqn,mbc,mx,my,xlower,ylower, &
     dx,dy,q,maux,aux)
  IMPLICIT NONE

  INTEGER meqn,mbc,mx,my,maux
  DOUBLE PRECISION xlower,ylower,dx,dy
  DOUBLE PRECISION q(meqn,1-mbc:mx+mbc, 1-mbc:my+mbc)
  DOUBLE PRECISION aux(maux,1-mbc:mx+mbc, 1-mbc:my+mbc)

  DOUBLE PRECISION xc,yc,xp,yp,zp, width, r, pressure

  INTEGER i,j

  INTEGER blockno, fc2d_clawpack5_get_block
  INTEGER*8 cont, get_context
  LOGICAL fclaw2d_map_is_used

  DOUBLE PRECISION pi
  COMMON /compi/ pi

  blockno = fc2d_clawpack5_get_block()
  cont = get_context()

  width = 0.2d0

  DO  i = 1-mbc,mx+mbc
     xc = xlower + (i-0.5d0)*dx
     DO j = 1-mbc,my+mbc
        yc = ylower + (j-0.5d0)*dy
        IF (fclaw2d_map_is_used(cont)) THEN
           CALL fclaw2d_map_c2m(cont,blockno,xc,yc,xp,yp,zp)
           r = SQRT(xp**2 + yp**2)
        ELSE
           r = SQRT(xc**2 + yc**2)
        ENDIF
        IF (ABS(r-0.5d0) .LE. width) THEN
           pressure = 1.d0 + COS(pi*(r - 0.5d0)/width)
        ELSE
           pressure = 0.d0
        ENDIF
        q(1,i,j) = pressure
        q(2,i,j) = 0.d0
        q(3,i,j) = 0.d0

     ENDDO
  ENDDO
END SUBROUTINE clawpack5_qinit


SUBROUTINE LUBKSBX (A , B , INDX ,  N , NP)
IMPLICIT NONE
!DATA DECLARATION
REAL(8) R0    /0.0D0/
CHARACTER	  NAME*6
DATA NAME/'LUBKSB'/
!SCALAR VARIABLES FROM ARGUMENTS
INTEGER N, NP
!ARRAYS FROM ARGUMENTS
REAL(8), DIMENSION(NP,NP):: A
REAL(8), DIMENSION(N):: B
INTEGER, DIMENSION(N):: INDX
!LOCAL SCALAR VARIABLES
INTEGER II, I, LL, J
REAL(8) SUM
!INITIALIZE LOCAL SCALAR VARIABLES
II=0;   I=0;    LL=0;   J=0;
SUM=R0;
!***********************************************************************
! Routine to solve the set of N linear equations AX=B
! See NUMERICAL RECIPES p36.
!*ACRONYM
! LU_BacK_SuBustitutions
!*DESCRIPTION
!*EXTERNAL
! Arrays
! A      - LU decomposed matrix
!=B      - Right hand side matrix as input and stored solutions as output
! INDX   - Permutation vector
! Variables
! N      - Size of the problem
! NP     - Physical size of A matrix
!***********************************************************************
II=0
! Do forward substitution, equation (2.3.6)
DO 12 I=1,N
	LL=INDX(I)
        SUM=B(LL)
        B(LL)=B(I)
        IF (II.NE.0)THEN
        	DO 11 J=II,I-1
            		SUM=SUM-A(I,J)*B(J)
   		11     CONTINUE
        ELSEIF (SUM.NE.R0) THEN
          	II=I
        ENDIF
        B(I)=SUM
12 CONTINUE
! Do the backsubstitution, equation (2.3.7)
DO 14 I=N,1,-1
	SUM=B(I)
        IF(I.LT.N)THEN
		DO 13 J=I+1,N
            		SUM=SUM-A(I,J)*B(J)
   		13     CONTINUE
        ENDIF
! Store a component of the solution vector Xi
        B(I)=SUM/A(I,I)
14 CONTINUE
RETURN
END