subroutine sld_bouope(a,ndime,iboun,e,sz,bc,elmat,elrhs,ndofn,npoinLocal)
!This subroutine computes the boundary contribution for the Cauchy eqn
!-----------------------------------------------------------------------
   use typre
   use Mod_Element
   use Mod_Solids
   implicit none
   class(SolidsProblem),target :: a
   class(FiniteElement)        :: e
   integer(ip),intent(in)      :: npoinLocal,iboun,ndime,ndofn,bc
   real(rp),intent(inout)      :: elmat(ndofn,e%mnode,ndofn,e%mnode)              ! Element matrices
   real(rp),intent(inout)      :: elrhs(ndofn,e%mnode)
   integer(ip) :: igaub,inodb,inode,ilnod,idime,sz,ielem
   real(rp)    :: tract(ndime,e%pnodb),tract_b(ndime)
   real(rp)    :: dsurf,dsurf0
   real(rp)    :: c_el(sz,sz),w

      call e%elmdel

      !Gather operations
      tract=0.0_rp
      tract_b=0.0_rp

      if(associated(a%trac)) then

          call e%gatherb(ndime,tract,a%trac(:,:))

      else if(a%kfl_fixbo(iboun) == 2) then

          tract_b(1:e%ndime) = a%bvnat(iboun)%a(1:e%ndime)

      end if

      dsurf0 = 0.0_rp

      !Gauss-Point Loop
      do igaub=1,e%pgaub
         e%igaub = igaub

         ielem = e%lboel(e%pnodb+1)
         a%btraction(ielem)%a(:,igaub) = 0.0_rp

         !Calculate exterior Normal
         call e%bounor

         !Derivatives at the boundary
         call e%elmderb

         dsurf=e%weigb(e%igaub)*e%eucta
         dsurf0 = dsurf0 + dsurf

         do inodb=1,e%pnodb
             inode = e%lboel(inodb)
             ilnod = e%lnods(inode)

             do idime=1,ndime
                 !elrhs= elrhs + N_i*t_f*ds
                 elrhs(bc+idime,inode)=elrhs(bc+idime,inode)    &
                     & - e%shapb(inodb,e%igaub)*tract(idime,inodb)*dsurf  & !FSI (or ext distributed) nodal tractions
                     & + e%shapb(inodb,e%igaub)*tract_b(idime)*dsurf        !Prescribed boundary tractions

             end do

             !We store the above for output
             a%btraction(ielem)%a(:,igaub) = a%btraction(ielem)%a(:,igaub)  &
                 & - e%shapb(inodb,e%igaub)*tract(:,inodb)

         end do

         !We store the above for output
         a%btraction(ielem)%a(:,igaub) = a%btraction(ielem)%a(:,igaub) + tract_b(:)
     end do

 end subroutine sld_bouope


      subroutine dgefa(a,lda,n,ipvt,info)
      integer lda,n,ipvt(n),info
      double precision a(lda,n)
c
c     dgefa factors a double precision matrix by gaussian elimination.
c
c     dgefa is usually called by dgeco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c     (time for dgeco) = (1 + 9/n)*(time for dgefa) .
c
c     on entry
c
c        a       double precision(lda, n)
c                the matrix to be factored.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c     on return
c
c        a       an upper triangular matrix and the multipliers
c                which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that dgesl or dgedi will divide by zero
c                     if called.  use  rcond  in dgeco for a reliable
c                     indication of singularity.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,dscal,idamax
c
c     internal variables
c
      double precision t
      integer idamax,j,k,kp1,l,nm1
c
c
c     gaussian elimination with partial pivoting
c
      info = 0
      nm1 = n - 1
      if (nm1 .lt. 1) go to 70
      do 60 k = 1, nm1
         kp1 = k + 1
c
c        find l = pivot index
c
         l = idamax(n-k+1,a(k,k),1) + k - 1
         ipvt(k) = l
c
c        zero pivot implies this column already triangularized
c
         if (a(l,k) .eq. 0.0d0) go to 40
c
c           interchange if necessary
c
            if (l .eq. k) go to 10
               t = a(l,k)
               a(l,k) = a(k,k)
               a(k,k) = t
   10       continue
c
c           compute multipliers
c
            t = -1.0d0/a(k,k)
            call dscal(n-k,t,a(k+1,k),1)
c
c           row elimination with column indexing
c
            do 30 j = kp1, n
               t = a(l,j)
               if (l .eq. k) go to 20
                  a(l,j) = a(k,j)
                  a(k,j) = t
   20          continue
               call daxpy(n-k,t,a(k+1,k),1,a(k+1,j),1)
   30       continue
         go to 50
   40    continue
            info = k
   50    continue
   60 continue
   70 continue
      ipvt(n) = n
      if (a(n,n) .eq. 0.0d0) info = n
      return
      end
      subroutine dgesl(a,lda,n,ipvt,b,job)
      integer lda,n,ipvt(n),job
      double precision a(lda,n),b(n)
c
c     dgesl solves the double precision system
c     a * x = b  or  trans(a) * x = b
c     using the factors computed by dgeco or dgefa.
c
c     on entry
c
c        a       double precision(lda, n)
c                the output from dgeco or dgefa.
c
c        lda     integer
c                the leading dimension of the array  a .
c
c        n       integer
c                the order of the matrix  a .
c
c        ipvt    integer(n)
c                the pivot vector from dgeco or dgefa.
c
c        b       double precision(n)
c                the right hand side vector.
c
c        job     integer
c                = 0         to solve  a*x = b ,
c                = nonzero   to solve  trans(a)*x = b  where
c                            trans(a)  is the transpose.
c
c     on return
c
c        b       the solution vector  x .
c
c     error condition
c
c        a division by zero will occur if the input factor contains a
c        zero on the diagonal.  technically this indicates singularity
c        but it is often caused by improper arguments or improper
c        setting of lda .  it will not occur if the subroutines are
c        called correctly and if dgeco has set rcond .gt. 0.0
c        or dgefa has set info .eq. 0 .
c
c     to compute  inverse(a) * c  where  c  is a matrix
c     with  p  columns
c           call dgeco(a,lda,n,ipvt,rcond,z)
c           if (rcond is too small) go to ...
c           do 10 j = 1, p
c              call dgesl(a,lda,n,ipvt,c(1,j),0)
c        10 continue
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,ddot
c
c     internal variables
c
      double precision ddot,t
      integer k,kb,l,nm1
c
      nm1 = n - 1
      if (job .ne. 0) go to 50
c
c        job = 0 , solve  a * x = b
c        first solve  l*y = b
c
         if (nm1 .lt. 1) go to 30
         do 20 k = 1, nm1
            l = ipvt(k)
            t = b(l)
            if (l .eq. k) go to 10
               b(l) = b(k)
               b(k) = t
   10       continue
            call daxpy(n-k,t,a(k+1,k),1,b(k+1),1)
   20    continue
   30    continue
c
c        now solve  u*x = y
c
         do 40 kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/a(k,k)
            t = -b(k)
            call daxpy(k-1,t,a(1,k),1,b(1),1)
   40    continue
      go to 100
   50 continue
c
c        job = nonzero, solve  trans(a) * x = b
c        first solve  trans(u)*y = b
c
         do 60 k = 1, n
            t = ddot(k-1,a(1,k),1,b(1),1)
            b(k) = (b(k) - t)/a(k,k)
   60    continue
c
c        now solve trans(l)*x = y
c
         if (nm1 .lt. 1) go to 90
         do 80 kb = 1, nm1
            k = n - kb
            b(k) = b(k) + ddot(n-k,a(k+1,k),1,b(k+1),1)
            l = ipvt(k)
            if (l .eq. k) go to 70
               t = b(l)
               b(l) = b(k)
               b(k) = t
   70       continue
   80    continue
   90    continue
  100 continue
      return
      end
      subroutine dgbfa(abd,lda,n,ml,mu,ipvt,info)
      integer lda,n,ml,mu,ipvt(n),info
      double precision abd(lda,n)
c
c     dgbfa factors a double precision band matrix by elimination.
c
c     dgbfa is usually called by dgbco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c
c     on entry
c
c        abd     double precision(lda, n)
c                contains the matrix in band storage.  the columns
c                of the matrix are stored in the columns of  abd  and
c                the diagonals of the matrix are stored in rows
c                ml+1 through 2*ml+mu+1 of  abd .
c                see the comments below for details.
c
c        lda     integer
c                the leading dimension of the array  abd .
c                lda must be .ge. 2*ml + mu + 1 .
c
c        n       integer
c                the order of the original matrix.
c
c        ml      integer
c                number of diagonals below the main diagonal.
c                0 .le. ml .lt. n .
c
c        mu      integer
c                number of diagonals above the main diagonal.
c                0 .le. mu .lt. n .
c                more efficient if  ml .le. mu .
c     on return
c
c        abd     an upper triangular matrix in band storage and
c                the multipliers which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that dgbsl will divide by zero if
c                     called.  use  rcond  in dgbco for a reliable
c                     indication of singularity.
c
c     band storage
c
c           if  a  is a band matrix, the following program segment
c           will set up the input.
c
c                   ml = (band width below the diagonal)
c                   mu = (band width above the diagonal)
c                   m = ml + mu + 1
c                   do 20 j = 1, n
c                      i1 = max0(1, j-mu)
c                      i2 = min0(n, j+ml)
c                      do 10 i = i1, i2
c                         k = i - j + m
c                         abd(k,j) = a(i,j)
c                10    continue
c                20 continue
c
c           this uses rows  ml+1  through  2*ml+mu+1  of  abd .
c           in addition, the first  ml  rows in  abd  are used for
c           elements generated during the triangularization.
c           the total number of rows needed in  abd  is  2*ml+mu+1 .
c           the  ml+mu by ml+mu  upper left triangle and the
c           ml by ml  lower right triangle are not referenced.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,dscal,idamax
c     fortran max0,min0
c
c     internal variables
c
      double precision t
      integer i,idamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1
c
c
      m = ml + mu + 1
      info = 0
c
c     zero initial fill-in columns
c
      j0 = mu + 2
      j1 = min0(n,m) - 1
      if (j1 .lt. j0) go to 30
      do 20 jz = j0, j1
         i0 = m + 1 - jz
         do 10 i = i0, ml
            abd(i,jz) = 0.0d0
   10    continue
   20 continue
   30 continue
      jz = j1
      ju = 0
c
c     gaussian elimination with partial pivoting
c
      nm1 = n - 1
      if (nm1 .lt. 1) go to 130
      do 120 k = 1, nm1
         kp1 = k + 1
c
c        zero next fill-in column
c
         jz = jz + 1
         if (jz .gt. n) go to 50
         if (ml .lt. 1) go to 50
            do 40 i = 1, ml
               abd(i,jz) = 0.0d0
   40       continue
   50    continue
c
c        find l = pivot index
c
         lm = min0(ml,n-k)
         l = idamax(lm+1,abd(m,k),1) + m - 1
         ipvt(k) = l + k - m
c
c        zero pivot implies this column already triangularized
c
         if (abd(l,k) .eq. 0.0d0) go to 100
c
c           interchange if necessary
c
            if (l .eq. m) go to 60
               t = abd(l,k)
               abd(l,k) = abd(m,k)
               abd(m,k) = t
   60       continue
c
c           compute multipliers
c
            t = -1.0d0/abd(m,k)
            call dscal(lm,t,abd(m+1,k),1)
c
c           row elimination with column indexing
c
            ju = min0(max0(ju,mu+ipvt(k)),n)
            mm = m
            if (ju .lt. kp1) go to 90
            do 80 j = kp1, ju
               l = l - 1
               mm = mm - 1
               t = abd(l,j)
               if (l .eq. mm) go to 70
                  abd(l,j) = abd(mm,j)
                  abd(mm,j) = t
   70          continue
               call daxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1)
   80       continue
   90       continue
         go to 110
  100    continue
            info = k
  110    continue
  120 continue
  130 continue
      ipvt(n) = n
      if (abd(m,n) .eq. 0.0d0) info = n
      return
      end
      subroutine dgbsl(abd,lda,n,ml,mu,ipvt,b,job)
      integer lda,n,ml,mu,ipvt(n),job
      double precision abd(lda,n),b(n)
c
c     dgbsl solves the double precision band system
c     a * x = b  or  trans(a) * x = b
c     using the factors computed by dgbco or dgbfa.
c
c     on entry
c
c        abd     double precision(lda, n)
c                the output from dgbco or dgbfa.
c
c        lda     integer
c                the leading dimension of the array  abd .
c
c        n       integer
c                the order of the original matrix.
c
c        ml      integer
c                number of diagonals below the main diagonal.
c
c        mu      integer
c                number of diagonals above the main diagonal.
c
c        ipvt    integer(n)
c                the pivot vector from dgbco or dgbfa.
c
c        b       double precision(n)
c                the right hand side vector.
c
c        job     integer
c                = 0         to solve  a*x = b ,
c                = nonzero   to solve  trans(a)*x = b , where
c                            trans(a)  is the transpose.
c
c     on return
c
c        b       the solution vector  x .
c
c     error condition
c
c        a division by zero will occur if the input factor contains a
c        zero on the diagonal.  technically this indicates singularity
c        but it is often caused by improper arguments or improper
c        setting of lda .  it will not occur if the subroutines are
c        called correctly and if dgbco has set rcond .gt. 0.0
c        or dgbfa has set info .eq. 0 .
c
c     to compute  inverse(a) * c  where  c  is a matrix
c     with  p  columns
c           call dgbco(abd,lda,n,ml,mu,ipvt,rcond,z)
c           if (rcond is too small) go to ...
c           do 10 j = 1, p
c              call dgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0)
c        10 continue
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,ddot
c     fortran min0
c
c     internal variables
c
      double precision ddot,t
      integer k,kb,l,la,lb,lm,m,nm1
c
      m = mu + ml + 1
      nm1 = n - 1
      if (job .ne. 0) go to 50
c
c        job = 0 , solve  a * x = b
c        first solve l*y = b
c
         if (ml .eq. 0) go to 30
         if (nm1 .lt. 1) go to 30
            do 20 k = 1, nm1
               lm = min0(ml,n-k)
               l = ipvt(k)
               t = b(l)
               if (l .eq. k) go to 10
                  b(l) = b(k)
                  b(k) = t
   10          continue
               call daxpy(lm,t,abd(m+1,k),1,b(k+1),1)
   20       continue
   30    continue
c
c        now solve  u*x = y
c
         do 40 kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/abd(m,k)
            lm = min0(k,m) - 1
            la = m - lm
            lb = k - lm
            t = -b(k)
            call daxpy(lm,t,abd(la,k),1,b(lb),1)
   40    continue
      go to 100
   50 continue
c
c        job = nonzero, solve  trans(a) * x = b
c        first solve  trans(u)*y = b
c
         do 60 k = 1, n
            lm = min0(k,m) - 1
            la = m - lm
            lb = k - lm
            t = ddot(lm,abd(la,k),1,b(lb),1)
            b(k) = (b(k) - t)/abd(m,k)
   60    continue
c
c        now solve trans(l)*x = y
c
         if (ml .eq. 0) go to 90
         if (nm1 .lt. 1) go to 90
            do 80 kb = 1, nm1
               k = n - kb
               lm = min0(ml,n-k)
               b(k) = b(k) + ddot(lm,abd(m+1,k),1,b(k+1),1)
               l = ipvt(k)
               if (l .eq. k) go to 70
                  t = b(l)
                  b(l) = b(k)
                  b(k) = t
   70          continue
   80       continue
   90    continue
  100 continue
      return
      end
      subroutine daxpy(n,da,dx,incx,dy,incy)
c
c     constant times a vector plus a vector.
c     uses unrolled loop for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      integer i,incx,incy,ix,iy,m,mp1,n
      double precision dx(*),dy(*),da
c
      if(n.le.0)return
      if (da .eq. 0.0d0) return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dy(iy) + da*dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,4)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dy(i) = dy(i) + da*dx(i)
   30 continue
      if( n .lt. 4 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,4
        dy(i) = dy(i) + da*dx(i)
        dy(i + 1) = dy(i + 1) + da*dx(i + 1)
        dy(i + 2) = dy(i + 2) + da*dx(i + 2)
        dy(i + 3) = dy(i + 3) + da*dx(i + 3)
   50 continue
      return
      end
      subroutine dcopy(n,sx,incx,sy,incy)
c
c     copies a vector, x, to a vector, y.
c     uses unrolled loops for increments equal to 1.
c     jack dongarra, linpack, 3/11/78.
c
      double precision sx(*),sy(*)
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        sy(iy) = sx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,7)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        sy(i) = sx(i)
   30 continue
      if( n .lt. 7 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,7
        sy(i) = sx(i)
        sy(i + 1) = sx(i + 1)
        sy(i + 2) = sx(i + 2)
        sy(i + 3) = sx(i + 3)
        sy(i + 4) = sx(i + 4)
        sy(i + 5) = sx(i + 5)
        sy(i + 6) = sx(i + 6)
   50 continue
      return
      end
      subroutine dscal(n,da,dx,incx)
c
c     scales a vector by a constant.
c     uses unrolled loop for increment equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision da,dx(*)
      integer i,incx,m,mp1,n,nincx
c
      if(n.le.0)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      nincx = n*incx
      do 10 i = 1,nincx,incx
        dx(i) = da*dx(i)
   10 continue
      return
c
c        code for increment equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dx(i) = da*dx(i)
   30 continue
      if( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dx(i) = da*dx(i)
        dx(i + 1) = da*dx(i + 1)
        dx(i + 2) = da*dx(i + 2)
        dx(i + 3) = da*dx(i + 3)
        dx(i + 4) = da*dx(i + 4)
   50 continue
      return
      end
      double precision function ddot(n,dx,incx,dy,incy)
c
c     forms the dot product of two vectors.
c     uses unrolled loop for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(*),dy(*),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
c
      ddot = 0.0d0
      dtemp = 0.0d0
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dtemp + dx(ix)*dy(iy)
        ix = ix + incx
        iy = iy + incy
   10 continue
      ddot = dtemp
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dtemp + dx(i)*dy(i)
   30 continue
      if( n .lt. 5 ) go to 60
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) +
     *   dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4)
   50 continue
   60 ddot = dtemp
      return
      end
      integer function idamax(n,dx,incx)
c
c     finds the index of element having max. absolute value.
c     jack dongarra, linpack, 3/11/78.
c
      double precision dx(*),dmax
      integer i,incx,ix,n
c
      idamax = 0
      if(n.lt.1) return
      idamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      dmax = dabs(dx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(dabs(dx(ix)).le.dmax) go to 5
         idamax = i
         dmax = dabs(dx(ix))
    5    ix = ix + incx
   10 continue
      return
c
c        code for increment equal to 1
c
   20 dmax = dabs(dx(1))
      do 30 i = 2,n
         if(dabs(dx(i)).le.dmax) go to 30
         idamax = i
         dmax = dabs(dx(i))
   30 continue
      return
      end
      DOUBLE PRECISION FUNCTION DNRM2 ( N, X, INCX )
*     .. Scalar Arguments ..
      INTEGER                           INCX, N
*     .. Array Arguments ..
      DOUBLE PRECISION                  X( * )
*     ..
*
*  DNRM2 returns the euclidean norm of a vector via the function
*  name, so that
*
*     DNRM2 := sqrt( x'*x )
*
*
*
*  -- This version written on 25-October-1982.
*     Modified on 14-October-1993 to inline the call to DLASSQ.
*     Sven Hammarling, Nag Ltd.
*
*
*     .. Parameters ..
      DOUBLE PRECISION      ONE         , ZERO
      PARAMETER           ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     .. Local Scalars ..
      INTEGER               IX
      DOUBLE PRECISION      ABSXI, NORM, SCALE, SSQ
*     .. Intrinsic Functions ..
      INTRINSIC             ABS, SQRT
*     ..
*     .. Executable Statements ..
      IF( N.LT.1 .OR. INCX.LT.1 )THEN
         NORM  = ZERO
      ELSE IF( N.EQ.1 )THEN
         NORM  = ABS( X( 1 ) )
      ELSE
         SCALE = ZERO
         SSQ   = ONE
*        The following loop is equivalent to this call to the LAPACK
*        auxiliary routine:
*        CALL DLASSQ( N, X, INCX, SCALE, SSQ )
*
         DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX
            IF( X( IX ).NE.ZERO )THEN
               ABSXI = ABS( X( IX ) )
               IF( SCALE.LT.ABSXI )THEN
                  SSQ   = ONE   + SSQ*( SCALE/ABSXI )**2
                  SCALE = ABSXI
               ELSE
                  SSQ   = SSQ   +     ( ABSXI/SCALE )**2
               END IF
            END IF
   10    CONTINUE
         NORM  = SCALE * SQRT( SSQ )
      END IF
*
      DNRM2 = NORM
      RETURN
*
*     End of DNRM2.
*
      END


! MIT License
!
! Copyright (c) 2010-present David A. Kopriva and other contributors: AUTHORS.md
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!
! HOHQMesh contains code that, to the best of our knowledge, has been released as
! public domain software:
! * `b3hs_hash_key_jenkins`: originally by Rich Townsend,
!    https://groups.google.com/forum/#!topic/comp.lang.fortran/RWoHZFt39ng, 2005
! * `fmin`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
! * `spline`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
! * `seval`: originally by George Elmer Forsythe, Michael A. Malcolm, Cleve B. Moler,
!    Computer Methods for Mathematical Computations, 1977
!
! --- End License
!
!////////////////////////////////////////////////////////////////////////
!
!      Frenet.f90
!      Created: April 30, 2020 at 2:00 PM
!      By: David Kopriva
!
!////////////////////////////////////////////////////////////////////////
!
      Module Frenet
      USE SMCurveClass
      USE Geometry3DModule
      IMPLICIT NONE

      TYPE FrenetFrame
         REAL(KIND=RP) :: tangent(3)
         REAL(KIND=RP) :: normal(3)
         REAL(KIND=RP) :: coNormal(3)
      END TYPE FrenetFrame

      REAL(KIND=RP), PARAMETER :: zeroNormSize = 1.d-7
!
!     ========
      CONTAINS
!     ========
!
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE ComputeFrenetFrame(frame, t, curve, isDegenerate)
         IMPLICIT NONE
!
!        ---------
!        arguments
!        ---------
!
         CLASS(SMCurve)     :: curve
         TYPE(FrenetFrame)  :: frame
         REAL(KIND=RP)      :: t
         LOGICAL            :: isDegenerate
!
!        ---------------
!        Local variables
!        ---------------
!
         REAL(KIND=RP) :: x(3), xp(3), xpp(3)
         REAL(KIND=RP) :: d1
         REAL(KIND=RP) :: tangent(3), B(3), Nhat(3)

         x   = curve % positionAt(t)
         xp  = curve % tangentAt(t)
         xpp = curve % secondDerivativeAt(t)
!
!        --------------
!        Tangent vector
!        --------------
!
         tangent = xp
         CALL Normalize(tangent)
!
!        ---------------
!        Binormal vector
!        ---------------
!
         CALL Cross3D(u = tangent,v = xpp,cross = B)
         CALL Norm3D(u = B,norm = d1)
         isDegenerate = .TRUE.
         IF ( d1 .gt. zeroNormSize )     THEN
            CALL Normalize(B)
            isDegenerate = .FALSE.
         END IF
!
!        -------------
!        Normal vector
!        -------------
!
         CALL Cross3D(u = B, v = tangent, cross = Nhat)

         frame % coNormal = B
         frame % normal   = Nhat
         frame % tangent  = tangent

      END SUBROUTINE ComputeFrenetFrame
!
!////////////////////////////////////////////////////////////////////////
!
      SUBROUTINE ComputeParallelFrame(t, curve, frame, refFrame)
         IMPLICIT NONE
!
!        ---------
!        Arguments
!        ---------
!
         TYPE(FrenetFrame), INTENT(IN ) :: refFrame
         TYPE(FrenetFrame), INTENT(OUT) :: frame
         REAL(KIND=RP)                  :: t
         CLASS(SMCurve)                 :: curve
!
!        ---------------
!        Local Variables
!        ---------------
!
         REAL(KIND=RP) :: d1
         LOGICAL       :: isDegenerate

         CALL ComputeFrenetFrame(frame        = frame, &
                                 t            = t,     &
                                 curve        = curve, &
                                 isDegenerate = isDegenerate)

         IF ( isDegenerate )     THEN
            frame % coNormal = refFrame % coNormal
            frame % normal   = refFrame % normal
         END IF

         CALL Dot3D(u = refFrame % coNormal,v = frame % coNormal, dot = d1)
         IF(d1 < -zeroNormSize)     THEN
            frame % coNormal = -frame % coNormal
            CALL Cross3D(u = frame % coNormal, v = frame % tangent, cross = frame % normal)
         ENDIF

      END SUBROUTINE ComputeParallelFrame
!
!////////////////////////////////////////////////////////////////////////
!
      REAL(KIND=RP) FUNCTION FrameAngle(frame1, frame2)
         IMPLICIT NONE
!
!        ---------
!        Arguments
!        ---------
!
         TYPE(FrenetFrame) :: frame1, frame2
!
!        ---------------
!        Local variables
!        ---------------
!
         REAL(KIND=RP) :: cosTheta

         CALL Dot3D(u = frame1 % normal ,v = frame2 % normal, dot = cosTheta)
         cosTheta = MIN(cosTheta, 1.0_RP)

         FrameAngle = ACOS(cosTheta)

      END FUNCTION FrameAngle

      END Module Frenet


program tree_test
    use, intrinsic :: iso_fortran_env
    use random_mod
    use node_mod
    implicit none
    integer, parameter :: sp = REAL32
    real(kind=sp), parameter :: init_prob = 1.0_sp, factor = 0.75_sp, &
                                root_dist = 0.0_sp
    type(node_type) :: root

    ! initialize the random number generator to get a unique sequence per run
    call init_random_seed()

    ! initialize root node, and create a tree where each node value
    ! denotes a distance between it, and its parent
    call root%init_random(init_prob, factor, root_dist)

    ! print the tree
    call root%show()

    ! compute the number of nodes in the tree
    write (unit=output_unit, fmt="(A, I3)") "node count = ", &
            root%count_nodes()

    ! compute the maximum distance between the root and any leaf node
    write (unit=output_unit, fmt="(A, F6.3)") "max. distance =", &
            root%leaf_distance()

    ! clean up
    call root%finalize()

end program tree_test


      SUBROUTINE DCROSS(X,Y,Z)
C
C     DOUBLE PRECISION CROSS PRODUCT
C
      DOUBLE PRECISION        X(3)     ,Y(3)     ,Z(3)
C
      Z(1) = X(2)*Y(3) - X(3)*Y(2)
      Z(2) = Y(1)*X(3) - Y(3)*X(1)
      Z(3) = X(1)*Y(2) - X(2)*Y(1)
      RETURN
      END


c function pctile (datum, n, npct)
c
c This is a modification of a quick-sorting algorithm, which is intended
c to take in a vector of numbers, and return the value of the npct-th
c element in that vector:
c
c    dataum 			   input vector
c    n			           number of elements in dataum
c    npct			   npct-th element
c    pctile			   output value of function
c
c
c The array datum contains randomly ordered data
c
c
      real function pctile (datum, n, npct)
c
      implicit none
      integer n, npct
      real datum(1)
      integer min0, max0
      real dkey
      integer lo, hi, limlo, limhi
c
c Initialize the pointers.
c
      npct = max0 (1, min0 (n,npct))
      limlo = 1
      limhi = n
c
c Compare all elements in the sub-vector between limlo and limhi with
c the current key datum.
c
  100 dkey = datum (limlo)
      lo = limlo
      hi = limhi
c
c If lo equals hi, we have tested all the elements in the current search
c interval.
c
  101 continue
      if (lo .eq. hi) go to 200
      if (datum(hi) .le. dkey) go to 109
c
c The pointer hi is to be left pointing at a datum SMALLER than the
c key, which is intended to be overwritten.
c
      hi = hi - 1
c
      goto 101
  109 datum(lo) = datum(hi)
      lo = lo + 1
  110 continue
      if (lo .eq. hi) goto 200
      if (datum(lo) .ge. dkey) go to 119
      lo = lo + 1
c
      goto 110
  119 datum(hi) = datum(lo)
c
c The pointer LO is to be left pointing at a datum LARGER than the
c key, which is intended to be overwritten.
c
      hi = hi - 1
c
      go to 101
c
c lo and hi are equal, and point at a value which is intended to
c be overwritten.  Since all values below this point are less than
c the key and all values above this point are greater than the key,
c this is where we stick the key back into the vector.
c
  200 continue
c
c At this point in the subroutine, all data between limlo and lo-1,
c inclusive, are less than datum (lo), and all data between lo+1 and
c limhi are larger than dataum(lo).  If lo = npct, then datum(lo) is
c the value we are looking for.  If npct < lo, then we want to sort the
c values of datum from limlo to lo-1, inclusive, whereas if npct > lo,
c then we want to sort the values of datum from lo+1 to limhi,
c inclusive.
c
      datum(lo) = dkey
      if (npct - lo) 300, 900, 400
  300 limhi = lo - 1
      go to 100
  400 limlo = lo + 1
      go to 100
  900 pctile = datum(lo)
      return
      end


program ch0601
    ! Monthly Rainfall
    implicit none

    real :: total = 0., average = 0.
    real, dimension(1:12) :: rainfall
    integer :: month

    print *, ' type in the rainfall values'
    print *, ' one per line'
    do month = 1, 12
        read *, rainfall(month)
    end do
    do month = 1, 12
        total = total+rainfall(month)
    end do
    average = total/12
    print *, ' Average monthly rainfall was'
    print *, average
end program


program bin2hdf5_parallel

    ! Created by Manuel A. Diaz, ENSMA 2020

    USE HDF5 ! This module contains all necessary modules

    implicit none

    ! USE MPI ! This module should contains all necessary modules, but ...
    include "mpif.h" ! This module contains all necessary modules.

    ! IMPORTANT NOTE:
    ! Number of processes and size of data in x-direction should be multiples of 2 (1,2,4,8)

    !-------- initialize variables -------------
    character(len=256) :: input_file
    character(len=256) :: output_file
    character(len=10)  :: Nx_char
    character(len=10)  :: Ny_char
    character(len=10)  :: Nz_char
    character(len=3)   :: data_extension="h5"

    integer :: Nx, Ny, Nz       ! Array dimensions
    integer :: pointPosition    ! '.' location

    ! MPI definitions and calls.
    integer :: info = MPI_INFO_NULL
    integer :: comm = MPI_COMM_WORLD
    integer :: MPIsize, MPIrank, MPIerror
    integer :: input_file_id
    integer :: new_type, data_type = MPI_REAL8;
    integer (kind = MPI_OFFSET_KIND) :: disp=0
    integer, dimension(3) :: dims   ! dimensions full array
    integer, dimension(3) :: count  ! dimensions subarray
    integer, dimension(3) :: start  ! start coordinates

    ! hdf5 subroutines parameters
    integer(HID_T) :: output_file_id  ! File identifier
    integer(HID_T) :: dataset_id      ! Dataset identifier
    integer(HID_T) :: filespace_id    ! Dataspace identifier in file
    integer(HID_T) :: memspace_id     ! Dataspace identifier in memory
    integer(HID_T) :: proplist_id     ! Property list identifier
    integer        :: HDFerror        ! Error flags

    ! Data buffer and its properties
    integer,   parameter  :: fp=8          ! float data presicion
    real(fp), allocatable :: data (:,:,:)  ! Data to write
    integer               :: rank = 3      ! Dataset rank

    ! Hyperslab parameters
    integer(HSIZE_T), dimension(3) :: HDFdims   ! dimensions full array
    integer(HSIZE_T), dimension(3) :: HDFstart  ! dimensions subarray (hyperslab)
    integer(HSIZE_T), dimension(3) :: HDFcount  ! start coordinates of subarray

    !--------  Parse arguments from command --------------------
    if ( command_argument_count() .NE. 4 ) then
        print*, "Mode of use: mpirun -n # bin2hdf5_parallel.run [*.bin] [Nx] [Ny] [Nz]"; stop
    else
        call get_command_argument(1,input_file)
        call get_command_argument(2,Nx_char); read(Nx_char,*) Nx
        call get_command_argument(3,Ny_char); read(Ny_char,*) Ny
        call get_command_argument(4,Nz_char); read(Nz_char,*) Nz
        print*, "Attemping to read ",Nx,"Nx",Ny,"Ny",Nz,"Nz array."
    end if

    !-------- Set the name of the output files -----------------
    pointPosition = scan(trim(input_file),".", BACK=.true.)
    if (pointPosition>0) output_file = input_file(1:pointPosition)//data_extension

    ! --------------- Initialize MPI ---------------------------
    CALL MPI_INIT(MPIerror)
    CALL MPI_COMM_SIZE(comm, MPIsize, MPIerror)
    CALL MPI_COMM_RANK(comm, MPIrank, MPIerror)

    !-----define file space and local rank memory space --------
    ! Set dimensions filespace_id
    dims(1) = Nx
    dims(2) = Ny
    dims(3) = Nz
    ! Set dimensions of the memory space in each rank
    count(1) = dims(1)/MPIsize  ! dims(1)          ! dims(1)
    count(2) = dims(2)          ! dims(2)/MPIsize  ! dims(2)
    count(3) = dims(3)          ! dims(3)          ! dims(3)/MPIsize
    ! Define hyperslab starting point
    start(1) = MPIrank*count(1) ! 0                ! 0
    start(2) = 0                ! MPIrank*count(2) ! 0
    start(3) = 0                ! 0                ! MPIrank*count(3)
    ! Translate for HDF parameters
    HDFdims(1)=dims(1);  HDFcount(1)=count(1);  HDFstart(1)=start(1)
    HDFdims(2)=dims(2);  HDFcount(2)=count(2);  HDFstart(2)=start(2)
    HDFdims(3)=dims(3);  HDFcount(3)=count(3);  HDFstart(3)=start(3)

    !----------- Allocate the rank's memory space  -------------
    allocate ( data(count(1),count(2),count(3)) )

    !----------------- Initialize data_buffer ------------------
    ! fill buffer with data from the input_file
    call MPI_FILE_OPEN(MPI_COMM_WORLD, input_file, MPI_MODE_CREATE + MPI_MODE_RDWR, MPI_INFO_NULL, input_file_id, MPIerror)
    call MPI_BARRIER(MPI_COMM_WORLD, MPIerror)
    call MPI_TYPE_CREATE_SUBARRAY(rank, dims, count, start, MPI_ORDER_FORTRAN, data_type, new_type, MPIerror)
    call MPI_TYPE_COMMIT(new_type, MPIerror)
    call MPI_FILE_SET_VIEW(input_file_id, disp, data_type, new_type, 'native', MPI_INFO_NULL, MPIerror)
    call MPI_FILE_READ_ALL(input_file_id, data, count(1)*count(2)*count(3), data_type, MPI_STATUS_IGNORE, MPIerror)
    call MPI_TYPE_FREE(new_type, MPIerror)
    call MPI_BARRIER(MPI_COMM_WORLD, MPIerror)
    call MPI_FILE_CLOSE(input_file_id, MPIerror)

    !----------- Write the data_buffer to an HDF5 file ---------
    ! Initialize FORTRAN predefined datatypes
    CALL h5open_f(HDFerror)

    ! Setup file access property list with parallel I/O access.
    CALL h5pcreate_f(H5P_FILE_ACCESS_F, proplist_id, HDFerror)
    CALL h5pset_fapl_mpio_f(proplist_id, comm, info, HDFerror)

    ! Create the file collectively.
    CALL h5fcreate_f(output_file, H5F_ACC_TRUNC_F, output_file_id, HDFerror, access_prp = proplist_id)
    CALL h5pclose_f(proplist_id, HDFerror)

    ! Create the data space for the  dataset.
    CALL h5screate_simple_f(rank, HDFdims, filespace_id, HDFerror)

    ! Create the dataset with default properties.
    CALL h5dcreate_f(output_file_id, "IntArray", H5T_NATIVE_DOUBLE, filespace_id, dataset_id, HDFerror)
    CALL h5sclose_f(filespace_id, HDFerror)

    ! Each process defines dataset in memory and writes it to the hyperslab in the file.
    CALL h5screate_simple_f(rank, HDFcount, memspace_id, HDFerror)

    ! Select hyperslab in the file.
    CALL h5dget_space_f(dataset_id, filespace_id, HDFerror)
    CALL h5sselect_hyperslab_f (filespace_id, H5S_SELECT_SET_F, HDFstart, HDFcount, HDFerror)

    ! Create property list for collective dataset write
    CALL h5pcreate_f(H5P_DATASET_XFER_F, proplist_id, HDFerror)
    CALL h5pset_dxpl_mpio_f(proplist_id, H5FD_MPIO_COLLECTIVE_F, HDFerror)

    ! Write the dataset collectively.
    CALL h5dwrite_f(dataset_id, H5T_NATIVE_DOUBLE, data, HDFdims, HDFerror, &
            file_space_id = filespace_id, mem_space_id = memspace_id, xfer_prp = proplist_id)

    ! Write the dataset independently.
    ! CALL h5dwrite_f(dataset_id, H5T_NATIVE_DOUBLE, data, HDFdims, HDFerror, &
    !         file_space_id = filespace_id, mem_space_id = memspace_id)

    CALL h5sclose_f(filespace_id, HDFerror)     ! close file space
    CALL h5sclose_f(memspace_id, HDFerror)      ! close memory space
    CALL h5dclose_f(dataset_id, HDFerror)       ! Close dataset
    CALL h5pclose_f(proplist_id, HDFerror)      ! Close property list
    CALL h5fclose_f(output_file_id, HDFerror)   ! Close the file.
    CALL h5close_f(HDFerror)                    ! Close FORTRAN predefined datatypes.

    ! if everything goes well then report that:
    if (MPIrank.eq.0) print*, "translation *.bin to *.h5 successful :)"
    deallocate(data) ! Deallocate data buffer.

    ! ------------ Finalize MPI -----------------
    CALL MPI_FINALIZE(MPIerror)

    end program bin2hdf5_parallel


!
! wavy - A spectral ocean wave modeling and development framework
! Copyright (c) 2017, Wavebit Scientific LLC
! All rights reserved.
!
! Licensed under the BSD-3 clause license. See LICENSE for details.
!
module mod_utility

use mod_precision,only:ik => intkind,rk => realkind

implicit none

private

public :: diff
public :: diff_periodic
public :: ones
public :: range
public :: tile
public :: zeros

interface diff
  module procedure :: diff_1d
  module procedure :: diff_2d
endinterface diff

interface diff_periodic
  module procedure :: diff_periodic_1d
  module procedure :: diff_periodic_2d
endinterface diff_periodic

interface ones
  module procedure :: ones_int
  module procedure :: ones_real
endinterface ones

interface range
  module procedure :: range_int
  module procedure :: range_real
endinterface range

interface tile
  module procedure :: tile_1d_int
  module procedure :: tile_1d_real
  module procedure :: tile_2d_int
  module procedure :: tile_2d_real
  module procedure :: tile_3d_int
  module procedure :: tile_3d_real
endinterface tile

interface zeros
  module procedure :: zeros_int
  module procedure :: zeros_real
endinterface zeros

!===============================================================================
contains

!-------------------------------------------------------------------------------
pure function diff_1d(x) result(dx)
  !! Returns a centered-difference of a 1-d array, with first order
  !! differencing applied for the boundary points. This procedure is overloaded
  !! by the generic procedure `diff`.
  real(kind=rk),dimension(:),intent(in)  :: x !! Input array
  real(kind=rk),dimension(:),allocatable :: dx
  integer(kind=ik) :: idm
  idm = size(x)
  allocate(dx(idm))
  if(idm == 0)then
    return
  elseif(idm == 1)then
    dx = 0
    return
  endif
  dx(2:idm-1) = 0.5_rk*(x(3:idm)-x(1:idm-2))
  dx(1) = x(2)-x(1)
  dx(idm) = x(idm)-x(idm-1)
endfunction diff_1d
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure function diff_2d(x,dim) result(dx)
  !! Returns a centered-difference of a 2-d array along dimension dim, with
  !! first order differencing applied for the boundary points. This procedure is
  !! overloaded by the generic procedure `diff`.
  real(kind=rk),dimension(:,:),intent(in) :: x
    !! Input array
  integer(kind=ik),intent(in) :: dim
    !! Dimension along which to differentiate
  real(kind=rk),dimension(:,:),allocatable :: dx
  integer(kind=ik) :: idm,jdm
  idm = size(x,dim=1)
  jdm = size(x,dim=2)
  allocate(dx(idm,jdm))
  if(idm == 0)then
    return
  elseif(idm == 1)then
    dx = 0
    return
  endif
  if(dim == 1)then
    dx(2:idm-1,:) = 0.5_rk*(x(3:idm,:)-x(1:idm-2,:))
    dx(1,:) = x(2,:)-x(1,:)
    dx(idm,:) = x(idm,:)-x(idm-1,:)
  elseif(dim == 2)then
    dx(:,2:idm-1) = 0.5_rk*(x(:,3:idm)-x(:,1:idm-2))
    dx(:,1) = x(2,:)-x(:,1)
    dx(:,idm) = x(:,idm)-x(:,idm-1)
  else
    dx = 0
  endif
endfunction diff_2d
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure function diff_periodic_1d(x) result(dx)
  !! Returns a centered-difference of a 1-d array with periodic boundary
  !! conditions. This procedure is overloaded by the generic procedure `diff`.
  real(kind=rk),dimension(:),intent(in)  :: x !! Input array
  real(kind=rk),dimension(:),allocatable :: dx
  integer(kind=ik) :: idm
  idm = size(x)
  allocate(dx(idm))
  if(idm == 0)then
    return
  elseif(idm == 1)then
    dx = 0
    return
  endif
  dx(2:idm-1) = 0.5_rk*(x(3:idm)-x(1:idm-2))
  dx(1) = 0.5_rk*(x(2)-x(idm))
  dx(idm) = 0.5_rk*(x(1)-x(idm-1))
endfunction diff_periodic_1d
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure function diff_periodic_2d(x,dim) result(dx)
  !! Returns a centered-difference of a 2-d array along dimension dim, with
  !! periodic boundary conditions. This procedure is overloaded by the generic
  !! procedure `diff`.
  real(kind=rk),dimension(:,:),intent(in) :: x
    !! Input array
  integer(kind=ik),intent(in) :: dim
    !! Dimension along which to differentiate
  real(kind=rk),dimension(:,:),allocatable :: dx
  integer(kind=ik) :: idm,jdm
  idm = size(x,dim=1)
  jdm = size(x,dim=2)
  allocate(dx(idm,jdm))
  if(idm == 0)then
    return
  elseif(idm == 1)then
    dx = 0
    return
  endif
  if(dim == 1)then
    dx(2:idm-1,:) = 0.5_rk*(x(3:idm,:)-x(1:idm-2,:))
    dx(1,:) = 0.5_rk*(x(2,:)-x(idm,:))
    dx(idm,:) = 0.5_rk*(x(1,:)-x(idm-1,:))
  elseif(dim == 2)then
    dx(:,2:idm-1) = 0.5_rk*(x(:,3:idm)-x(:,1:idm-2))
    dx(:,1) = 0.5_rk*(x(:,2)-x(:,idm))
    dx(:,idm) = 0.5_rk*(x(:,1)-x(:,idm-1))
  else
    dx = 0
  endif
endfunction diff_periodic_2d
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure function ones_int(length,kindflag) result(ones)
  !! Returns a 1-d array of integer ones. This procedure is overloaded by the
  !! generic procedure `ones`.
  integer(kind=ik),intent(in) :: length   !! Array length
  integer(kind=ik),intent(in) :: kindflag !! Array type
  integer(kind=ik),dimension(:),allocatable :: ones
  allocate(ones(length))
  ones = 1
endfunction ones_int
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure function ones_real(length,kindflag) result(ones)
  !! Returns a 1-d array of floating-point ones. This procedure is overloaded by
  !! the generic procedure `ones`.
  integer(kind=ik),intent(in) :: length !! Array length
  real(kind=rk),intent(in) :: kindflag !! Array type
  real(kind=rk),dimension(:),allocatable :: ones
  allocate(ones(length))
  ones = 1._rk
endfunction ones_real
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure function range_int(start,end,increment) result(range)
  !! Returns an array of integers given start, end, and increment values. If the
  !! increment argument is not passed, default increment is 1. This procedure is
  !! overloaded by the generic procedure `range`.
  integer(kind=ik),intent(in) :: start
    !! Start value of the array
  integer(kind=ik),intent(in) :: end
    !! End value of the array
  integer(kind=ik),intent(in),optional :: increment
    !! Array increment
  integer(kind=ik),dimension(:),allocatable :: range
  integer(kind=ik) :: i
  integer(kind=ik) :: increment_
  integer(kind=ik) :: length
  if(present(increment))then
    increment_ = increment
  else
    increment_ = 1
  endif
  length = (end-start)/increment_+1
  allocate(range(length))
  do concurrent(i = 1:length)
    range(i) = start+(i-1)*increment_
  enddo
endfunction range_int
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure function range_real(start,end,increment) result(range)
  !! Returns an array of reals given start, end, and increment values. If the
  !! increment argument is not passed, default increment is 1. This procedure is
  !! overloaded by the generic procedure `range`.
  real(kind=rk),intent(in) :: start
    !! Start value of the array
  real(kind=rk),intent(in) :: end
    !! End value of the array
  real(kind=rk),intent(in),optional :: increment
    !! Array increment
  real(kind=rk),dimension(:),allocatable :: range
  real(kind=rk) :: increment_
  integer(kind=ik) :: i
  integer(kind=ik) :: length
  if(present(increment))then
    increment_ = increment
  else
    increment_ = 1
  endif
  length = int((end-start)/increment_)+1
  allocate(range(length))
  do concurrent(i = 1:length)
    range(i) = start+(i-1)*increment_
  enddo
endfunction range_real
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure function tile_1d_int(array,n) result(tiled_array)
  !! Tiles the input array `n` times. Returns a tiled array that has rank equal
  !! to `size(shape(array))+1` and that has values equal to values of `array`,
  !! repeated `n` times. This version is for 1-d input array of integers. This
  !! procedure is overloaded by the generic procedure `tile`.
  integer(kind=ik),dimension(:),intent(in) :: array !! Input array
  integer(kind=ik),intent(in) :: n !! Number of times to copy input array
  integer(kind=ik),dimension(:,:),allocatable :: tiled_array
  integer(kind=ik) :: i
  allocate(tiled_array(size(array),n))
  do concurrent(i=1:n)
    tiled_array(:,i) = array(:)
  enddo
endfunction tile_1d_int
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure function tile_1d_real(array,n) result(tiled_array)
  !! Tiles the input array `n` times. Returns a tiled array that has rank equal
  !! to `size(shape(array))+1` and that has values equal to values of `array`,
  !! repeated `n` times. This version is for 1-d input array of reals. This
  !! procedure is overloaded by the generic procedure `tile`.
  real(kind=rk),dimension(:),intent(in) :: array !! Input array
  integer(kind=ik),intent(in) :: n !! Number of times to copy input array
  real(kind=rk),dimension(:,:),allocatable :: tiled_array
  integer(kind=ik) :: i
  allocate(tiled_array(size(array),n))
  do concurrent(i=1:n)
    tiled_array(:,i) = array(:)
  enddo
endfunction tile_1d_real
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure function tile_2d_int(array,n) result(tiled_array)
  !! Tiles the input array `n` times. Returns a tiled array that has rank equal
  !! to `size(shape(array))+1` and that has values equal to values of `array`,
  !! repeated `n` times. This version is for 2-d input array of integers. This
  !! procedure is overloaded by the generic procedure `tile`.
  integer(kind=ik),dimension(:,:),intent(in) :: array !! Input array
  integer(kind=ik),intent(in) :: n !! Number of times to copy input array
  integer(kind=ik),dimension(:,:,:),allocatable :: tiled_array
  integer(kind=ik) :: i
  allocate(tiled_array(size(array,dim=1),size(array,dim=2),n))
  do concurrent(i=1:n)
    tiled_array(:,:,i) = array(:,:)
  enddo
endfunction tile_2d_int
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure function tile_2d_real(array,n) result(tiled_array)
  !! Tiles the input array `n` times. Returns a tiled array that has rank equal
  !! to `size(shape(array))+1` and that has values equal to values of `array`,
  !! repeated `n` times. This version is for 2-d input array of reals. This
  !! procedure is overloaded by the generic procedure `tile`.
  real(kind=rk),dimension(:,:),intent(in) :: array !! Input array
  integer(kind=ik),intent(in) :: n !! Number of times to copy input array
  real(kind=rk),dimension(:,:,:),allocatable :: tiled_array
  integer(kind=ik) :: i
  allocate(tiled_array(size(array,dim=1),size(array,dim=2),n))
  do concurrent(i=1:n)
    tiled_array(:,:,i) = array(:,:)
  enddo
endfunction tile_2d_real
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure function tile_3d_int(array,n) result(tiled_array)
  !! Tiles the input array `n` times. Returns a tiled array that has rank equal
  !! to `size(shape(array))+1` and that has values equal to values of `array`,
  !! repeated `n` times. This version is for 3-d input array of integers. This
  !! procedure is overloaded by the generic procedure `tile`.
  integer(kind=ik),dimension(:,:,:),intent(in) :: array !! Input array
  integer(kind=ik),intent(in) :: n !! Number of times to copy input array
  integer(kind=ik),dimension(:,:,:,:),allocatable :: tiled_array
  integer(kind=ik) :: i
  allocate(tiled_array(size(array,dim=1),size(array,dim=2),size(array,dim=3),n))
  do concurrent(i=1:n)
    tiled_array(:,:,:,i) = array(:,:,:)
  enddo
endfunction tile_3d_int
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure function tile_3d_real(array,n) result(tiled_array)
  !! Tiles the input array `n` times. Returns a tiled array that has rank equal
  !! to `size(shape(array))+1` and that has values equal to values of `array`,
  !! repeated `n` times. This version is for 3-d input array of reals. This
  !! procedure is overloaded by the generic procedure `tile`.
  real(kind=rk),dimension(:,:,:),intent(in) :: array !! Input array
  integer(kind=ik),intent(in) :: n !! Number of times to copy input array
  real(kind=rk),dimension(:,:,:,:),allocatable :: tiled_array
  integer(kind=ik) :: i
  allocate(tiled_array(size(array,dim=1),size(array,dim=2),size(array,dim=3),n))
  do concurrent(i=1:n)
    tiled_array(:,:,:,i) = array(:,:,:)
  enddo
endfunction tile_3d_real
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure function zeros_int(length,kindflag) result(zeros)
  !! Returns a 1-d array of integer zeros. This procedure is overloaded by the
  !! generic procedure `zeros`.
  integer(kind=ik),intent(in) :: length !! Array length
  integer(kind=ik),intent(in) :: kindflag !! Array type
  integer(kind=ik),dimension(:),allocatable :: zeros
  allocate(zeros(length))
  zeros = 0
endfunction zeros_int
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
pure function zeros_real(length,kindflag) result(zeros)
  !! Returns a 1-d array of floating-point zeros. This procedure is overloaded by
  !! the generic procedure `zeros`.
  integer(kind=ik),intent(in) :: length !! Array length
  real(kind=rk),intent(in) :: kindflag !! Array type
  real(kind=rk),dimension(:),allocatable :: zeros
  allocate(zeros(length))
  zeros = 0._rk
endfunction zeros_real
!-------------------------------------------------------------------------------
endmodule mod_utility


    program demo_ior
    implicit none
    integer :: i, j, k
       i=53       ! i=00110101 binary (lowest order byte)
       j=45       ! j=00101101 binary (lowest order byte)
       k=ior(i,j) ! k=00111101 binary (lowest order byte) , k=61 decimal
       write(*,'(i8,1x,b8.8)')i,i,j,j,k,k
    end program demo_ior


      SUBROUTINE CALDIFF (ISTL_,M,CON1)
C
C CHANGE RECORD
C **  SUBROUTINE CALDIFF CALCULATES THE HORIZONTAL DIFFUSIVE
C **  TRANSPORT OF DISSOLVED OR SUSPENDED CONSITITUENT M LEADING TO
C **  A REVISEDED VALUE AT TIME LEVEL (N+1). THE VALUE OF ISTL
C **  INDICATES THE NUMBER OF TIME LEVELS IN THE STEP
C
      USE GLOBAL
	IMPLICIT NONE
	INTEGER::K,L,LS,LW,M,ISTL_
	REAL::CON1
      DIMENSION CON1(LCM,KCM)
C
C **  HORIZONTAL DIFFUSIVE FLUX CALCULATION
C
      DO K=1,KC
        DO L=2,LA
          LS=LSC(L)
          LW=LWEST(L)
          FUHU(L,K)=FUHU(L,K)+0.5*SUB(L)*DYU(L)*HU(L)*(AH(L,K)+AH(LW,K))*
     &        (CON1(LW,K)-CON1(L,K))*DXIU(L)
          FVHU(L,K)=FVHU(L,K)+0.5*SVB(L)*DXV(L)*HV(L)*(AH(L,K)+AH(LS,K))*
     &        (CON1(LS,K)-CON1(L,K))*DYIV(L)
        ENDDO
      ENDDO
      RETURN
      END


subroutine CSDcalc(iw)
    use mtr
    use param
    implicit real*8 (A - H, O - Z)
    integer(8) iii

    x(  -nx - 1) = -Xmax
    hx = Xmax/(nL - 1)

    do i = -nx, nx + 1
        x(i) = x(i - 1) + hx
    end do

    Nd = Yl(1, its)
    do i = 0, nx + 1
        Nd(i) = Yl(i + 1, its) !Initial conditions
    end do
    nstep = 1000
    ii = 0
    tfin = ts(it)
    itim = 1
    !   write(*, *) ts(its), ts(it)
    dt = (tfin - ts(its))/nstep
    do t = ts(its), tfin, dt
        do i = -nx + 1, nx + 1
            x(i) = x(i) + Uu(max(x(i), 0d0), t) * dt
            if (x(i) .gt. 0) then
                Nd(i) = Nd(i)/(1d0 + dUdx * dt)
            else
                Nd(i) = exp(Znn(t))
            end if
            if (mod(ii, 999) .eq. 0 .and. iw == 1) write(12, '(I5,2e15.5)') i, x(i), log(Nd(i)) !.and. x(i) >= 0  !Nd(i).gt.0d0.and.
        end do
        if (mod(ii, 999) .eq. 0.and.iw == 1) write(12, *)
        if (mod(ii, 999) .eq. 0.and.iw == 1) write(12, *)
        ii = ii + 1
    end do
endsubroutine CSDcalc

real*8  function tt(z, x0, x1, x2, y0, y1, y2)
    implicit real*8 (a - h, o - z)
    tt = (z - x1)*(z - x2) * y0/(x0 - x1)/(x0 - x2)+(z - x0)*(z - x2) * y1/(x1 - x0)/(x1 - x2)+(z - x0)*(z - x1) * y2/(x2 - x0)/(x2 - x1)
end function tt

real*8  function dtt(z, x0, x1, x2, y0, y1, y2)
    implicit real*8 (a - h, o - z)
    t1 = y1 - y2
    t2 = x0**2
    t7 = y2 - y0
    t8 = x1**2
    dtt = (t1 * t2 - 2 * z * t1 * x0 + t7 * t8 - 2 * z * t7 * x1 - 2 * x2 * (-x2/2 + z)*(y0 - y1))/(x0 - x1)/(x0 - x2)/(x1 - x2)
end function dtt

subroutine read_data
    use MTR
    use param
    implicit real*8 (A - H, O - Z)
    character*190 str
    character*2 c1
    Yl(:, 0) = -100d0
    ts(0) = 0
    nm = 10
    read(12, '(A100)', end = 111) str
    read(12, '(A100)', end = 111) str
    read(str, *, end = 111) c1, (ts(i), i = 1, nt)
    !   write(*,'(10i10)')0,int(ts)
    do i = 1, nm
        read(12, *, end = 111) xx(i), (CSD(i, j), j = 1, nt)
        !       write(*,'(10f10.3)')xx(i),(CSD(i,j),j=1,nt)
    end do
    do j = 1, nt
        do i = 1, nm
            if (CSD(i, j) .ne. - 99.0d0) then
                x1 = xx(i)
                x2 = xx(i + 1)
                exit
            end if
        end do
        ii = 1
        do while (xl(ii) < x1) !linear interpolation to 0
            Yl(ii, j) = CSD(i, j)+(CSD(i + 1, j) - CSD(i, j))*(xl(ii) - x1)/(x2 - x1)
            !           write(*,*)ii,xl(ii),Yl(ii,j)
            ii = ii + 1
        end do

        do k = ii, nl
            do ix = i, nm
                if (xl(k) >= xx(ix - 1).and.xl(k) < xx(ix)) exit
            end do
            if (ix < nm + 1.and.CSD(ix, J) .ne. - 98d0) then
                Yl(k, j) = CSD(ix - 1, j)+(CSD(ix, j) - CSD(ix - 1, j))*(xl(k) - xx(ix - 1))/(xx(ix) - xx(ix - 1))
            else
                Yl(k, j) = -100d0
            end if
            !           write(*,*)k,xl(k),Yl(k,j)
        end do
    end do
    return
    111 continue
    write(*, *) 'error reading files'
end subroutine read_data

real*8  function Zn(t)
    use mtr
    implicit real*8 (A - H, O - Z)
    Zn = Yl(1, its)+(Yl(1, it) - Yl(1, its))*(t - ts(its))/(ts(it) - ts(its))
end function Zn

real*8  function Znn(t)
    use param
    use mtr
    implicit real*8 (A - H, O - Z)
    Jz = 1 + (nj - 1) * (t - tn0(1))/(tn0(nj) - tn0(1))

    J1 = Jz - 1
    J2 = Jz
    J3 = Jz + 1
    if (Jz == nj) then
        J1 = Jz - 2
        J2 = Jz - 1
        J3 = Jz
    end if

    if (Jz == 1) then
        J1 = Jz
        J2 = Jz + 1
        J3 = Jz + 2
    end if
    Znn = tt(t, tn0(J1), tn0(j2), tn0(J3), Zn0(J1), Zn0(J2), Zn0(J3))
end function Znn

real*8  function Uu(z, t)
    use param
    use mtr
    implicit real*8 (A - H, O - Z)
    Jz = 1 + (nj - 1) * (t - tn0(1))/(tn0(nj) - tn0(1))
    J1 = Jz - 1
    J2 = Jz
    J3 = Jz + 1
    if (Jz == nj) then
        J1 = Jz - 2
        J2 = Jz - 1
        J3 = Jz
    end if

    if (Jz == 1) then
        J1 = Jz
        J2 = Jz + 1
        J3 = Jz + 2
    end if
    Ft = tt(t, tn0(J1), tn0(j2), tn0(J3), FtU(J1), FtU(J2), FtU(J3))

    Jz = 1 + (nu - 1) * z/xmax
    J1 = Jz - 1
    J2 = Jz
    J3 = Jz + 1
    if (Jz == nu) then
        J1 = Jz - 2
        J2 = Jz - 1
        J3 = Jz
    end if

    if (Jz == 1) then
        J1 = Jz
        J2 = Jz + 1
        J3 = Jz + 2
    end if

    if (z < xmax) then
        Uu = Ft * tt(z, xu(J1), xu(j2), xu(J3), U(J1), U(J2), U(J3))
        dUdx = Ft * dtt(z, xu(J1), xu(j2), xu(J3), U(J1), U(J2), U(J3))
    end if
end function Uu

subroutine fsq(Xp, F)
    use param
    use mtr
    implicit real*8 (a - h, o - z)
    real*8 Xp(nu + 2 * nj)
    U = Xp(1:nu)
    FtU = Xp(nu + 1:nu + nj)
    Zn0 = Xp(nu + nj + 1:nu + 2 * nj)
    call CSDcalc(0)

    F = 0.0d0

    do j = 1, nl
        iok = 0
        do i = -nx, nx
            if (x(i - 1) <= xl(j).and. x(i) > xl(j)) then
                Csdc = (log(Nd(i - 1))+(log(Nd(i)) - log(Nd(i - 1)))*(xl(j) - x(i - 1))/(x(i) - x(i - 1)))
                F = F + sqrt((log(Yl(j, it)) - Csdc)**2)/nl !correct later
                iok = 1
            end if
        end do
        if (iok == 0) F = F + sqrt(log(Yl(j, it)))/nl
    end do

    write(117, *)
    write(*, "(A5,F10.5)") 'sq=', F
    if (abs(F - 0.023) < 0.001) then
        do i = -nx, nx
            write(102, *) x(i), log(Nd(i))
        end do
        write(102, *)
        write(102, *)

        do i = 1, nl
            write(102, *) xl(i), log(Yl(i, it))
        end do

!        write(*, *) Xp
        open(122, file = 'par' // fn // '.txt')
        write(122, '(100e15.7)') Xp
        close(122)

        !stop
    end if
    !  write(*,'(5e12.5)')Zn0
    return

end subroutine fsq

subroutine fcons(x, fc)
    use param
    double precision fc, s
    double precision x(nu + 2 * nj)

    fc = 0.d0
    do i = 1, nu
        ! Nonnegative values:
        s = -x(i) !max(-x(i) - 0.01, x(i) - 0.025)
        if (s .gt. fc) then
            fc = s
        endif
    enddo
end subroutine fcons


ccc_____________________________________________________________________
ccc
      subroutine pshftsd(x,nfreq,nch,dr,nwin,start_rec)

ccc   subroutine corrects for offsets in sampling times in seed files
ccc   almost the same as phs_shft; special version for seed files
ccc   allows for possible changes in time shifts during run.

      include 'seed.inc'

      complex tc,t
      real x(nch,2,nfreq),dr,t1,pi2
      integer nwin,start_rec
      parameter(pi2 = 6.28318)

      do j = 1,nch
ccc      check to see if starting record number is past next
ccc      sampling phase shift change
ccc      NOTE: assuming here that we won't ever have to jump
ccc         forward more than one segment (i.e., every shift
ccc         in the phase has at least one data set)
ccc      ALSO:  we shift to the next phase when the first set
ccc         with starting record past the limit is found ...
ccc         this will always be a level 1 set; some higher level
ccc         sets with earlier starts will still be accumulating
ccc        data ... but phase correction should be small for higher
ccc        level sets, these sets (if any) will stradle the change, etc.
         if(start_rec .ge. dt_chng_rec(j,dt_chng_i(j))) then
            dt_chng_i(j) = dt_chng_i(j) + 1
         endif

ccc      now do the phase shift
         t1 =   -pi2*(dt0 + dt(j,dt_chng_i(j)))/(dr*nwin)
         do i = 1,nfreq
            tc = cmplx(cos(i*t1),sin(i*t1))
            t = tc*cmplx(x(j,1,i),x(j,2,i))
            x(j,1,i) = real(t)
            x(j,2,i) = aimag(t)
         enddo
      enddo
      return
      end


       SUBROUTINE MakePhaseSpace_2body(p1,m1,p2,m2,k,phaseSpace2)

         IMPLICIT NONE
         INTEGER          i
         DOUBLE PRECISION m1,m2,p1Mod,phaseSpace2,beta
         DOUBLE PRECISION k(0:3),p1(0:3),p2(0:3),LamSqr
         EXTERNAL         LamSqr
         INCLUDE 'MC_Declare.h'

         phaseSpace2 = 1d0/4d0/pi**2

         k(0)  = 0d0
         p1(0) = (mb**2+m1**2-m2**2)/2d0/mb
         p2(0) = (mb**2+m2**2-m1**2)/2d0/mb
         p1Mod = Dsqrt(p1(0)**2-m1**2)
         Call RandVectOnSp3b(p1Mod,p1)
         DO i=1,3
           p2(i) =-p1(i)
           k(i)  = 0d0
         ENDDO
         beta = LamSqr(mb**2,m1**2,m2**2)
c                                                    cosTh    ph
         phaseSpace2 = phaseSpace2*beta/8d0/mb**2 * 2d0*pi * 2d0

       RETURN
       END

       SUBROUTINE MakePhaseSpace_3body(p1,m1,p2,m2,k,phaseSpace)
c################################################################################
c                                                                               #
c  This procedure makes transformation of p1 and p2 momentas from `R' to `Lab'  #
c  frame and returns p1,p2 and k momentas in LAB frame, which obey momenta      #
c  conservation law: p1+p2+k=Q (in `Lab' frame: Q(3-vector)=0, Q(0)=mb )        #
c  (rest frame of Z) and magnitude of the 3-particle `phaseSpace' volume ...    #
c  Collinearity and IR-divergence are taken into account...                     #
c                                                                               #
c  p1,p2      --- fermion momentas                                              #
c  k          --- photon momenta                                                #
c  phaseSpace --- 3-Particle Phase Space Volume                                 #
c                                                                               #
c################################################################################
         IMPLICIT NONE
         DOUBLE PRECISION s,sMin,sMax,theta3,ph3,LamSqr,spMin
         DOUBLE PRECISION FRanGen,kMod,p1Mod,expH,spMax,r,sp,p2Mod
         DOUBLE PRECISION p1(0:3),p2(0:3),k(0:3),m1,m2
         DOUBLE PRECISION phaseFactor,phaseSpace,engConserv,momConserv
         EXTERNAL         FRanGen,LamSqr
         INCLUDE 'MC_Declare.h'

         PhaseSpace = 1d0/2d0**11/pi**5

c.. Simulation of  ivnariant mass of F anti_F system => s, with the density 1/(mb**2-s)
c.. NOTATIONS: s=(p1+p2)^2 , sp=mb^2-s
         spMax    = 2d0*mb*k0Max   ! k0Max - upper limit for photon nergy, less then kinematicaly allowed!

         spMin    = 2d0*mb*omega
         r  = FRanGen()
         sp = spMax*(spMin/spMax)**r  ! below: Jackobian factor
         phaseSpace = phaseSpace * 4d0*Dlog(spMax/spMin)

c.. Photon momenta simulation  in LAB frame...
         k(0) = sp/2d0/mb
         kMod = k(0)
         CALL RandVectOnSp3b(kMod,k)
         CALL GetAngles(k,theta3,ph3)
         phaseSpace = phaseSpace * 2d0 * 2d0*pi

c.. F-anti_F momenta simulation in R frame <==> p1+p2==0...
c.. We have changed flat distribution of (p1+p2) to 1/(1-(beta*cos(theta))**2),
c.. taking into account a collinearity !!!
         s = mb**2-sp
         p1(0) = (s+m1**2-m2**2)/2d0/Dsqrt(s)
         p2(0) = (s+m2**2-m1**2)/2d0/Dsqrt(s)
         p1Mod = Dsqrt(p1(0)**2-m1**2)
         CALL RandVectOnSp3_coll(p1Mod,p1,phaseFactor)
         p2(1) =-p1(1)
         p2(2) =-p1(2)
         p2(3) =-p1(3)                                ! below: Jackobian factor
         phaseSpace = phaseSpace*LamSqr(s,m1**2,m2**2)/s * phaseFactor

c.. Boost from R to LAB frame.....
c.. (NOTE: Z-axis of R frame points to k 3-vector and gamma_euler==0,
c..  we have a freedom of rotation about z-axis of R frame !!! )
         expH = mb/Dsqrt(s)
         CALL BoostZ(expH,p1,p1)
         CALL BoostZ(expH,p2,p2)
c.. after this Boost, (p1+p2) 3-vector points opposite to k 3-vector...

c.. One have to make transformation from the BOOSTED coordinate frame to the LAB frame...
c.. Rotate about X-axis...
         CALL RotateX(theta3,p1,p1)
         CALL RotateX(theta3,p2,p2)

c.. Rotate about Z-axis...
         CALL RotateZ(pi/2d0-ph3,p1,p1)
         CALL RotateZ(pi/2d0-ph3,p2,p2)

c.. Check, that all is right: k+p1+p2==0 as a 3-vector in `LAB' frame...
         momConserv = +(p1(1)+p2(1)+k(1))**2
     &                +(p1(2)+p2(2)+k(2))**2
     &                +(p1(3)+p2(3)+k(3))**2
         engConserv = (p1(0)+p2(0)+k(0)-mb)**2  ! mb = p1(0)+p2(0)+k(0) in LAB frame !!
         IF (momConserv.GT.1d-20.OR.engConserv.GT.1d-20) THEN
            PRINT*, ""
            PRINT*, "ERROR IN MakePhaseSpace_3body : "
            PRINT*, "      TRANSFORMATION FROM `R' TO `LAB': ----> ERROR"
            PRINT*, ""
            STOP
         ENDIF

       RETURN
       END

       DOUBLE PRECISION FUNCTION LamSqr(x,y,z)

         IMPLICIT NONE
         DOUBLE PRECISION x,y,z

         LamSqr = Dsqrt( (x+y-z)**2-4d0*x*y )

       RETURN
       END

       DOUBLE PRECISION FUNCTION ScalProd4_pm(p,q)
c##########################################################
c          Calculates Scalar product of 4-vectors         #
c                    in Pauli metric                      #
c##########################################################
         IMPLICIT NONE
         DOUBLE PRECISION p(0:3),q(0:3)

         ScalProd4_pm = p(1)*q(1)+p(2)*q(2)+p(3)*q(3)-p(0)*q(0)

       RETURN
       END

       DOUBLE PRECISION FUNCTION ScalProd4(p,q)
c#####################################################
c      Calculates Scalar product of 4-vectors        #
c            in Bjorken-Drell metric...              #
c#####################################################
         IMPLICIT NONE
         DOUBLE PRECISION p(0:3),q(0:3)

         ScalProd4 = p(0)*q(0)-p(1)*q(1)-p(2)*q(2)-p(3)*q(3)

       RETURN
       END


c=======================================================================
c
c     subroutine  SDLSCOR
c
c     Semi-Definite Least Square optimization
c     for a correlation matrix with M >= alpha     ( 0.0 =<alpha < 1.0 )
c
c-----------------------------------------------------------------------
      SUBROUTINE sdlscor ( nmat, cmat, epsbfg, alpha, iwork, dwork,
     &                     xmat, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            nmat   : dimension of the matrix                    integer
c            cmat   : symmetric matrix(nmat*nmat) to optimize     double
c            epsbfg : BFGS precision stop test                    double
c            alpha  : alpha  ( 0.0 =<alpha < 1.0 )                double
c
c     WORKSPACE
c            iwork  : ( 14*nmat + 2 )                            integer
c            dwork  : ( nmat*(7*nmat + 40) )                      double
c
c     OUTPUT
c            xmat   : matrix solution (nmat*nmat)                 double
c            info   : diagnostic argument                        integer
c
c     CALL
c        SEMDX   : computing the sum of the diagonal elements of a
c                  matrix with a scalar : B = A + x*I
c                  ( A square matrix(n*n), x scalar,
c                    gives B square matrix(n*n) )
c        PMX     : computing M*X = matrix
c                  ( M matrix(n*m), X scalar, gives M*X matrix(n*m) )
c        YM      : copy a vectorized matrix in a vectorized matrix
c        CMCMS    : converting a vector of full square matrix
c                   in vector of symmetric matrix
c        BFGSSDLS : quasi-Newton optimizer with BFGS method
c                   ( short call version for SDLS )
c        SIMSCOR  : subroutine used by BFGS to compute the value of the
c                   dual function and its gradient
c                   specific to obtain a correlation matrix
c        SOLSCOR  : computing the solution of SDLS optimization from the
c                   dual solution   x = pK( C + Ai.y(i) )
c                   specific to obtain a correlation matrix
c        CMSMC    : converting a vector of symmetric matrix
c                   in vector of full square matrix
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
      EXTERNAL simscor, gesterr
c
c     i/o arguments
      INTEGER nmat, info
      DOUBLE PRECISION epsbfg, alpha, cmat(*), xmat(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, ssm, mct, totitr, totsim, piw, pinfo, pdw, pdcv, pdxs,
     &        pdyd, pdbinf, pdbsup, pdgrad, pdcs
      DOUBLE PRECISION eps, infini, opalph, invopa, funct
      PARAMETER ( eps = 1.e-15, infini = 1.d20 )
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
c
c     test if alpha in [0,1]
      IF ( (alpha .LT. 0.).or.(alpha .GT. (1. - eps)) ) THEN
         info = -2001
         RETURN
      ENDIF
c
      ssm    = nmat*(nmat+1)/2
      mct    = nmat
      opalph = (1.-alpha)
      invopa = 1./opalph
c
c     pointers for integer work space  : iwork
c     ----------------------------------------
      piw   = 1
c     piw   : pointer for local workspaces,
c             BFGSSDLS needs (2*mct+1)
c                      + communication with SIMSCOR (12*nmat+1),
c                      so ((2*mct+1)+(12*nmat+1))
c             SOLSCOR needs (12*nmat)
c             so, union of spaces : ((2*mct+1)+(12*nmat+1))
c             for correlation mct = nmat,
c             so : (14*nmat+2)
c
c     Total size of iwork array = (14*nmat+2)
c
      pinfo  = piw + (2*mct+1)
c     pinfo  : communication pointer with SIMCOR for info
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdcv   = 1
c     pdcv   : pointer for changed variable matrix C(nmat*nmat)
      pdxs   = pdcv + (nmat*nmat)
c     pdxs   : pointer for the vectorized symmetric matrix X,
c              so ssm = (nmat*(nmat+1)/2) more
      pdyd   = pdxs + ssm
c     pdyd   : pointer for initial value of ydual, so mct more
      pdbinf = pdyd + mct
c     pdbinf : pointer for inferior bounds binf, so mct more
      pdbsup = pdbinf + mct
c     pdbsup : pointer for superior bounds bsup, so mct more
      pdgrad = pdbsup + mct
c     pdgrad : pointer for gradient at solution, so mct more
      pdw    = pdgrad + mct
c     pdw    : pointer for local workspaces,
c             BFGSSDLS needs ( mct*(mct+11)/2 )
c                      + communication with SIMSCOR ( mct*(5*mct+30) ),
c                      for correlation mct = nmat
c                      so ( nmat*(nmat+11)/2 )+ ( nmat*(5*nmat+30) )
c             SOLSCOR needs (nmat*(nmat+1)/2 + nmat*(3*nmat+27))
c             so, union of spaces: (nmat*(nmat+11)/2)+(nmat*(5*nmat+30 )
c
c     Total size of dwork array = (nmat*nmat) + ssm + 4*mct
c                           + ( mct*(mct+11)/2 ) + ( mct*(5*mct+30) )
c     for correlation mct = nmat
c        = (nmat*nmat) + (nmat*(nmat+1)/2) + 4*nmat
c          + ( nmat*(mnat+11)/2 ) + ( nmat*(5*nmat+30) )
c        = nmat*( nmat + ((nmat+1)/2)+((nmat+11)/2)+(5*nmat+30)+4 )
c        = nmat * ( nmat + (2*nmat+12)/2) + (5*nmat+30) + 4 )
c        = nmat * ( nmat + (nmat+6) + (5*nmat+30) + 4 )
c
c     = nmat * (7*nmat+40)
c
      pdcs  = pdw +  mct*(mct+11)/2
c     pdcs  :  communication pointer with SIMCOR
c              for the vectorized symmetric matrix C,
c
c-----------------------------------------------------------------------
c
c     chgt. variable CA = (C - alpha*I) / (1-alpha)), if alpha > epsilon
      IF (alpha .GT. eps) THEN
         CALL SEMDX ( nmat, cmat, -alpha, dwork(pdcv) )
         CALL PMX ( nmat, nmat, dwork(pdcv), invopa, dwork(pdcv) )
      ELSE
         CALL YM ( nmat, nmat, cmat, dwork(pdcv) )
      ENDIF
c
c     initialization of ydual
      DO i = 1,mct
         dwork(pdyd+i-1) = 0.
      ENDDO
c
c     initializations of bounds
      DO i = 1,mct
         dwork(pdbinf+i-1) = -infini
         dwork(pdbsup+i-1) = infini
      ENDDO
c
c     construction of iwork vector (communication with simscor)
      iwork(pinfo) = 0
c
c     conversion of the full matrix C in vectorized symmetric matrix
c     in dwork vector (communication with simscor)
      CALL CMCMS ( nmat, dwork(pdcv), dwork(pdcs) )
c
c     non-linear optimization (BFGS)
c
c     (the second parameter is not used here, we can replace GESTERR
c      by an other name of subroutine)
      CALL bfgssdls ( simscor, gesterr, mct, dwork(pdyd), epsbfg,
     &                dwork(pdbinf), dwork(pdbsup),
     &                iwork(piw), dwork(pdw),
     &                funct, dwork(pdgrad), totitr, totsim,
     &                info)
c
c     gestion of SIMSCOR errors
      info = iwork(pinfo)
c
c     construction of the matrix solution from dual solution
      CALL solscor ( nmat, dwork(pdcs), dwork(pdyd),
     &               iwork(piw), dwork(pdw),
     &               dwork(pdxs), info )
c
c     conversion of the vectorized symmetric matrix X in full matrix
      CALL CMSMC ( nmat, dwork(pdxs), dwork(pdcv) )
c
c     changing variable X = Z + alpha*I if alpha > epsilon
      IF (alpha .GT. eps) THEN
         CALL PMX ( nmat, nmat, dwork(pdcv), opalph, dwork(pdcv) )
         CALL SEMDX ( nmat, dwork(pdcv), alpha, xmat )
      ELSE
         CALL YM ( nmat, nmat, dwork(pdcv), xmat )
      ENDIF
c
c     restore corr(i,i) = 1.0
      DO i = 1,nmat
        xmat(i + (i-1)*nmat) = 1.0
      ENDDO
c
      RETURN
      END


        subroutine pcdp(pc,p,d)
        common/gfgmp/p1(2),p2(2)
        dimension pc(2),p(2)
        r=sqrt((p(1)-pc(1))**2+(p(2)-pc(2))**2)
        sita1=d/r
        sita2=-d/r
        p1(1)=(p(1)-pc(1))*cos(sita1)-(p(2)-pc(2))*sin(sita1)+pc(1)
        p1(2)=(p(1)-pc(1))*sin(sita1)+(p(2)-pc(2))*cos(sita1)+pc(2)
        p2(1)=(p(1)-pc(1))*cos(sita2)-(p(2)-pc(2))*sin(sita2)+pc(1)
        p2(2)=(p(1)-pc(1))*sin(sita2)+(p(2)-pc(2))*cos(sita2)+pc(2)
        return
        end


SUBROUTINE interpolate_fields(nlon, nlat, nlev, kmax, uu, vv, temp, plev, height, &
                              aa, omega, dz, hh, rr, cp, pv, ut, vt, theta, stat)

    INTEGER, INTENT(IN) :: nlon, nlat, nlev, kmax
    REAL, INTENT(IN) :: uu(nlon,nlat,nlev), vv(nlon,nlat,nlev), temp(nlon,nlat,nlev), &
                        plev(nlev), height(kmax)
    REAL, INTENT(in) :: aa, omega, dz,hh, rr, cp
    REAL, INTENT(out) :: pv(nlon,nlat,kmax), ut(nlon,nlat,kmax), vt(nlon,nlat,kmax)
    REAL, INTENT(out) :: theta(nlon,nlat,kmax), stat(kmax)

    REAL ::  tt(nlon,nlat,nlev),tz(nlat,kmax),tzd(nlat,kmax)
    REAL ::  uz(nlat,kmax),uzd(nlat,kmax)
    REAL ::  vz(nlat,kmax),vzd(nlat,kmax)
    REAL ::  oz(nlat,kmax),ozd(nlat,kmax)
    REAL ::  tm(nlon,nlat,kmax)
    REAL ::  xlon(nlon),ylat(nlat)
    REAL ::  t0(kmax),zlev(nlev)
    REAL ::  st(nlon,nlat),zmst(nlat)
    REAL ::  avort(nlon,nlat,kmax),zmav(nlat,kmax)
    REAL ::  zmpv(nlat,kmax)
    REAL :: rkappa, pi, dphi

    rkappa = rr/cp
    pi = acos(-1.)
    dphi = pi/float(nlat-1)

    ! ====  vertical interpolation ====
    do k = 1,nlev
        zlev(k) = -hh*alog(plev(k)/1000.)
    enddo

    do i = 1,nlon
        do j = 1,nlat

            do k = 1,nlev
                tt(i,j,k) = temp(i,j,k)*((1000./plev(k))**rkappa)
            enddo

            st(i,j) = tt(i,j,1)      ! surface pot. temp

            do kk = 1,kmax   ! vertical interpolation
                ttt = height(kk)
                do k = 1,nlev-1
                    tt2 = zlev(k+1)
                    tt1 = zlev(k)
                    if((ttt.ge.tt1).and.(ttt.lt.tt2)) then
                        dd1 = (ttt-tt1)/(tt2-tt1)
                        dd2 = 1.-dd1
                        theta(i,j,kk) = tt(i,j,k)*dd2 + tt(i,j,k+1)*dd1
                        ut(i,j,kk) = uu(i,j,k)*dd2 + uu(i,j,k+1)*dd1
                        vt(i,j,kk) = vv(i,j,k)*dd2 + vv(i,j,k+1)*dd1
                        goto 348
                    endif
                enddo
                348 continue
            enddo
        enddo
    enddo

    !  **** compute zonal mean ****
    tz = 0.
    uz = 0.
    vz = 0.

    tzd = 0.
    uzd = 0.
    vzd = 0.

    do j = 1,nlat
        do k = 1,kmax
            do i = 1,nlon
                tzd(j,k) = tzd(j,k) + theta(i,j,k)/float(nlon)
                uzd(j,k) = uzd(j,k) + ut(i,j,k)/float(nlon)
                vzd(j,k) = vzd(j,k) + vt(i,j,k)/float(nlon)
                tz(j,k) = tz(j,k)+theta(i,j,k)/(float(nlon))
                uz(j,k) = uz(j,k)+ut(i,j,k)/(float(nlon))
                vz(j,k) = vz(j,k)+vt(i,j,k)/(float(nlon))
            enddo
        enddo
    enddo

    ! reference theta
    do kk = 1,kmax
        t0(kk) = 0.
        csm = 0.
        do j = 1,nlat
            phi0 = -90.+float(j-1)*180./float(nlat-1)
            phi0 = phi0*pi/180.
            t0(kk) = t0(kk) + tzd(j,kk)*cos(phi0)
            csm = csm + cos(phi0)
        enddo
        t0(kk) = t0(kk)/csm
    enddo

    ! static stability
    do kk = 2,kmax-1
        stat(kk) = (t0(kk+1)-t0(kk-1))/(height(kk+1)-height(kk-1))
    enddo
    stat(kmax) = (t0(kmax)-t0(kmax-1))/(height(kmax)-height(kmax-1))
    stat(1) = (t0(2)-t0(1))/(height(2)-height(1))

    ! surface temp

    do j = 1,nlat
        zmst(j) = 0.
        do i = 1,nlon
            zmst(j) = zmst(j) + st(i,j)/float(nlon)
        enddo
    enddo

    ! interior abs. vort

    do kk = 1,kmax
        do j = 2,nlat-1
            phi0 = -90.+float(j-1)*180./float(nlat-1)
            phi0 = phi0*pi/180.
            phim = -90.+float(j-2)*180./float(nlat-1)
            phim = phim*pi/180.
            phip = -90.+float(j)*180./float(nlat-1)
            phip = phip*pi/180.

            do i = 2,nlon-1
                av1 = 2.*omega*sin(phi0)
                av2 = (vt(i+1,j,kk)-vt(i-1,j,kk))/(2.*aa*cos(phi0)*dphi)
                av3 = -(ut(i,j+1,kk)*cos(phip)-ut(i,j-1,kk)*cos(phim))/(2.*aa*cos(phi0)*dphi)
                avort(i,j,kk) = av1+av2+av3
            enddo

            av1 = 2.*omega*sin(phi0)
            av2 = (vt(2,j,kk)-vt(nlon,j,kk))/(2.*aa*cos(phi0)*dphi)
            av3 = -(ut(1,j+1,kk)*cos(phip)-ut(1,j-1,kk)*cos(phim))/(2.*aa*cos(phi0)*dphi)
            avort(1,j,kk) = av1+av2+av3
            av4 = 2.*omega*sin(phi0)
            av5 = (vt(1,j,kk)-vt(nlon-1,j,kk))/(2.*aa*cos(phi0)*dphi)
            av6 =   &
            -(ut(nlon,j+1,kk)*cos(phip)-ut(nlon,j-1,kk)*cos(phim))/(2.*aa*cos(phi0)*dphi)
            avort(nlon,j,kk) = av4+av5+av6
        enddo

        avs = 0.
        avn = 0.
        do i = 1,nlon
            avs = avs + avort(i,2,kk)/float(nlon)
            avn = avn + avort(i,nlat-1,kk)/float(nlon)
        enddo
        avort(:,1,kk) = avs
        avort(:,nlat,kk) = avn
    enddo

    ! zonal mean vort

    do kk = 1,kmax
        do j = 1,nlat
            zmav(j,kk) = 0.
            do i = 1,nlon
                zmav(j,kk) = zmav(j,kk)+avort(i,j,kk)/float(nlon)
            enddo
        enddo
    enddo

    ! interior pv

    do kk = 2,kmax-1
        do j = 1,nlat
            phi0 = -90.+float(j-1)*180./float(nlat-1)
            phi0 = phi0*pi/180.
            f = 2.*omega*sin(phi0)
            do i = 1,nlon
                altp = exp(-height(kk+1)/hh)*(theta(i,j,kk+1)-t0(kk+1))/stat(kk+1)
                altm = exp(-height(kk-1)/hh)*(theta(i,j,kk-1)-t0(kk-1))/stat(kk-1)
                altp = altp
                altm = altm
                strc = (altp-altm)*zmav(j,kk)/(height(kk+1)-height(kk-1))
                !     strc = (altp-altm)*f/(height(kk+1)-height(kk-1))
                pv(i,j,kk) = avort(i,j,kk) + exp(height(kk)/hh)*strc
            enddo
        enddo
    enddo

    ! zonal mean pv

    do kk = 1,kmax
        do j = 1,nlat
            zmpv(j,kk) = 0.
            do i = 1,nlon
                zmpv(j,kk) = zmpv(j,kk)+pv(i,j,kk)/float(nlon)
            enddo
        enddo
    enddo

END SUBROUTINE


!----- kinematic file for WpWmg production
c--- note: this is the same point as used in Appendix B of 0710.1832

c--- \begin{array}{rrrrrrr}
c---      p_1 & = true( 0.00000000000000, 0.00000000000000, 1021.22119318758,-1021.22119318758
c---      p_2 & = true( 0.00000000000000, 0.00000000000000,-238.714576090637,-238.714576090637
c---      p_3 & = true(-71.5344542606618,-183.877222508616,-3.11006048502754, 197.326337775966
c---      p_4 & = true(-9.92033815503652,-76.1125676676337, 49.0057636944973, 91.0664644166627
c---      p_5 & = true( 32.5059044554765, 245.099246845329,-495.644737899924, 553.889863453468
c---      p_6 & = true( 64.1786550096635, 124.613643938661,-207.896850811885, 250.736037681104
c---      p_7 & = true(-15.2297670494417,-109.723100607740,-124.860731594604, 166.917065951017).\\

c--- momenta are written in Kirill's notation true(E,px,py,pz)

      theta=pi/4d0
      phi=pi/6d0
      rho=pi/3d0
      csig=-7d0/19d0

      mt=0.4255266775d0
      muk=6d0
      ssig=sqrt(1d0-csig**2)

      p1true(1)=-0.5d0*muk
      p1true(2)=-p1true(1)*sin(theta)
      p1true(3)=-p1true(1)*cos(theta)*sin(phi)
      p1true(4)=-p1true(1)*cos(theta)*cos(phi)

      p4true(1)=muk/3d0
      p4true(2)=p4true(1)
      p4true(3)=0d0
      p4true(4)=0d0

      p3true(1)=muk/7d0
      p3true(2)=p3true(1)*csig
      p3true(3)=p3true(1)*ssig
      p3true(4)=0d0

      p2true(1)=-0.5d0*muk
      p2true(2)=+p2true(1)*sin(theta)
      p2true(3)=+p2true(1)*cos(theta)*sin(phi)
      p2true(4)=+p2true(1)*cos(theta)*cos(phi)

      p5true(1)=muk/6d0
      p5true(2)=+p5true(1)*cos(rho)*csig
      p5true(3)=+p5true(1)*cos(rho)*ssig
      p5true(4)=+p5true(1)*sin(rho)

      do nu=1,4
      p6true(nu)=-p1true(nu)-p2true(nu)-p3true(nu)-p4true(nu)-p5true(nu)
      enddo

      p(1,4)=p1true(1)
      p(1,1)=p1true(2)
      p(1,2)=p1true(3)
      p(1,3)=p1true(4)

      p(2,4)=p2true(1)
      p(2,1)=p2true(2)
      p(2,2)=p2true(3)
      p(2,3)=p2true(4)

      p(3,4)=p3true(1)
      p(3,1)=p3true(2)
      p(3,2)=p3true(3)
      p(3,3)=p3true(4)

      p(4,4)=p4true(1)
      p(4,1)=p4true(2)
      p(4,2)=p4true(3)
      p(4,3)=p4true(4)

      p(5,4)=p5true(1)
      p(5,1)=p5true(2)
      p(5,2)=p5true(3)
      p(5,3)=p5true(4)

      p(6,4)=p6true(1)
      p(6,1)=p6true(2)
      p(6,2)=p6true(3)
      p(6,3)=p6true(4)


      subroutine spline (x,y,u,n,a,b,c,d,kode,ier)
C...subroutine     spline    01/09/73
C...subroutine     spline    01/09/78
      dimension x(n),y(n),u(n),a(n),b(n),c(n),d(n)
      a(2)=x(2)-x(1)
      if (kode.eq.2) goto 4
      call tdmp (x,y,n,a,b,c,d,kode)
      call tridig (u,n,a,b,c,d,kode,ier)
      if (ier.eq.0) goto 4
      call grafer ('SPLN')
      return
   4  do 5 i=2,n
      e=x(i)*y(i-1)
      f=x(i-1)*y(i)
      g=x(i-1)*x(i)
      r=u(i-1)*x(i)
      s=u(i)*x(i-1)
      h1=2./(x(i)-x(i-1))
      h2=h1*h1/4.
      d(i-1)=h2*(h1*g*(f-e)+e*x(i)+f*x(i-1)-g*(r+s))
      e=h1*(y(i)-y(i-1))
      f=x(i-1)+2.*x(i)
      h1=x(i)+2.*x(i-1)
      c(i-1)=h2*(-3.*e*g+r*h1+s*f)
      b(i-1)=1.5*h2*e*(f-x(i))-h2*(u(i-1)*f+u(i)*h1)
   5  a(i-1)=h2*(u(i)+u(i-1)-e)
      return
      end