c       this file contains the following user-callable routines:
c
c
c       routine idz_id2svd converts an approximation to a matrix
c       in the form of an ID to an approximation in the form of an SVD.
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
        subroutine idz_id2svd(m,krank,b,n,list,proj,u,v,s,ier,w)
c
c       converts an approximation to a matrix in the form of an ID
c       to an approximation in the form of an SVD.
c
c       input:
c       m -- first dimension of b
c       krank -- rank of the ID
c       b -- columns of the original matrix in the ID
c       list -- list of columns chosen from the original matrix
c               in the ID
c       n -- length of list and part of the second dimension of proj
c       proj -- projection coefficients in the ID
c
c       output:
c       u -- left singular vectors
c       v -- right singular vectors
c       s -- singular values
c       ier -- 0 when the routine terminates successfully;
c              nonzero otherwise
c
c       work:
c       w -- must be at least (krank+1)*(m+3*n+10)+9*krank**2
c            complex*16 elements long
c
c       _N.B._: This routine destroys b.
c
        implicit none
        integer m,krank,n,list(n),iwork,lwork,ip,lp,it,lt,ir,lr,
     1          ir2,lr2,ir3,lr3,iind,lind,iindt,lindt,lw,ier
        real*8 s(krank)
        complex*16 b(m,krank),proj(krank,n-krank),u(m,krank),
     1             v(n,krank),w((krank+1)*(m+3*n+10)+9*krank**2)
c
c
c       Allocate memory for idz_id2svd0.
c
        lw = 0
c
        iwork = lw+1
        lwork = 8*krank**2+10*krank
        lw = lw+lwork
c
        ip = lw+1
        lp = krank*n
        lw = lw+lp
c
        it = lw+1
        lt = n*krank
        lw = lw+lt
c
        ir = lw+1
        lr = krank*n
        lw = lw+lr
c
        ir2 = lw+1
        lr2 = krank*m
        lw = lw+lr2
c
        ir3 = lw+1
        lr3 = krank*krank
        lw = lw+lr3
c
        iind = lw+1
        lind = n/4+1
        lw = lw+1
c
        iindt = lw+1
        lindt = m/4+1
        lw = lw+1
c
c
        call idz_id2svd0(m,krank,b,n,list,proj,u,v,s,ier,
     1                   w(iwork),w(ip),w(it),w(ir),w(ir2),w(ir3),
     2                   w(iind),w(iindt))
c
c
        return
        end
c
c
c
c
        subroutine idz_id2svd0(m,krank,b,n,list,proj,u,v,s,ier,
     1                         work,p,t,r,r2,r3,ind,indt)
c
c       routine idz_id2svd serves as a memory wrapper
c       for the present routine (please see routine idz_id2svd
c       for further documentation).
c
        implicit none
c
        character*1 jobz
        integer m,n,krank,list(n),ind(n),indt(m),ifadjoint,
     1          lwork,ldu,ldvt,ldr,info,j,k,ier
        real*8 s(krank)
        complex*16 b(m,krank),proj(krank,n-krank),p(krank,n),
     1             r(krank,n),r2(krank,m),t(n,krank),r3(krank,krank),
     2             u(m,krank),v(n,krank),work(8*krank**2+10*krank)
c
c
c
        ier = 0
c
c
c
c       Construct the projection matrix p from the ID.
c
        call idz_reconint(n,list,krank,proj,p)
c
c
c
c       Compute a pivoted QR decomposition of b.
c
        call idzr_qrpiv(m,krank,b,krank,ind,r)
c
c
c       Extract r from the QR decomposition.
c
        call idz_rinqr(m,krank,b,krank,r)
c
c
c       Rearrange r according to ind.
c
        call idz_rearr(krank,ind,krank,krank,r)
c
c
c
c       Take the adjoint of p to obtain t.
c
        call idz_matadj(krank,n,p,t)
c
c
c       Compute a pivoted QR decomposition of t.
c
        call idzr_qrpiv(n,krank,t,krank,indt,r2)
c
c
c       Extract r2 from the QR decomposition.
c
        call idz_rinqr(n,krank,t,krank,r2)
c
c
c       Rearrange r2 according to indt.
c
        call idz_rearr(krank,indt,krank,krank,r2)
c
c
c
c       Multiply r and r2^* to obtain r3.
c
        call idz_matmulta(krank,krank,r,krank,r2,r3)
c
c
c
c       Use LAPACK to SVD r3.
c
        jobz = 'S'
        ldr = krank
        lwork = 8*krank**2+10*krank
     1        - (krank**2+2*krank+3*krank**2+4*krank)
        ldu = krank
        ldvt = krank
c
        call zgesdd(jobz,krank,krank,r3,ldr,s,work,ldu,r,ldvt,
     1              work(krank**2+2*krank+3*krank**2+4*krank+1),lwork,
     2              work(krank**2+2*krank+1),work(krank**2+1),info)
c
        if(info .ne. 0) then
          ier = info
          return
        endif
c
c
c
c       Multiply the u from r3 from the left by the q from b
c       to obtain the u for a.
c
        do k = 1,krank
c
          do j = 1,krank
            u(j,k) = work(j+krank*(k-1))
          enddo ! j
c
          do j = krank+1,m
            u(j,k) = 0
          enddo ! j
c
        enddo ! k
c
        ifadjoint = 0
        call idz_qmatmat(ifadjoint,m,krank,b,krank,krank,u,r2)
c
c
c
c       Take the adjoint of r to obtain r2.
c
        call idz_matadj(krank,krank,r,r2)
c
c
c       Multiply the v from r3 from the left by the q from p^*
c       to obtain the v for a.
c
        do k = 1,krank
c
          do j = 1,krank
            v(j,k) = r2(j,k)
          enddo ! j
c
          do j = krank+1,n
            v(j,k) = 0
          enddo ! j
c
        enddo ! k
c
        ifadjoint = 0
        call idz_qmatmat(ifadjoint,n,krank,t,krank,krank,v,r2)
c
c
        return
        end
c
c
c
c
        subroutine idz_matadj(m,n,a,aa)
c
c       Takes the adjoint of a to obtain aa.
c
c       input:
c       m -- first dimension of a, and second dimension of aa
c       n -- second dimension of a, and first dimension of aa
c       a -- matrix whose adjoint is to be taken
c
c       output:
c       aa -- adjoint of a
c
        implicit none
        integer m,n,j,k
        complex*16 a(m,n),aa(n,m)
c
c
        do k = 1,n
          do j = 1,m
            aa(k,j) = conjg(a(j,k))
          enddo ! j
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idz_matmulta(l,m,a,n,b,c)
c
c       multiplies a and b^* to obtain c.
c
c       input:
c       l -- first dimension of a and c
c       m -- second dimension of a and b
c       a -- leftmost matrix in the product c = a b^*
c       n -- first dimension of b and second dimension of c
c       b -- rightmost matrix in the product c = a b^*
c
c       output:
c       c -- product of a and b^*
c
        implicit none
        integer l,m,n,i,j,k
        complex*16 a(l,m),b(n,m),c(l,n),sum
c
c
        do i = 1,l
          do k = 1,n
c
            sum = 0
c
            do j = 1,m
              sum = sum+a(i,j)*conjg(b(k,j))
            enddo ! j
c
            c(i,k) = sum
c
          enddo ! k
        enddo ! i
c
c
        return
        end
c
c
c
c
        subroutine idz_rearr(krank,ind,m,n,a)
c
c       rearranges a according to ind obtained
c       from routines idzr_qrpiv or idzp_qrpiv,
c       assuming that a = q r, where q and r are from idzr_qrpiv
c       or idzp_qrpiv.
c
c       input:
c       krank -- rank obtained from routine idzp_qrpiv,
c                or provided to routine idzr_qrpiv
c       ind -- indexing array obtained from routine idzr_qrpiv
c              or idzp_qrpiv
c       m -- first dimension of a
c       n -- second dimension of a
c       a -- matrix to be rearranged
c
c       output:
c       a -- rearranged matrix
c
        implicit none
        integer k,krank,m,n,j,ind(krank)
        complex*16 cswap,a(m,n)
c
c
        do k = krank,1,-1
          do j = 1,m
c
            cswap = a(j,k)
            a(j,k) = a(j,ind(k))
            a(j,ind(k)) = cswap
c
          enddo ! j
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idz_rinqr(m,n,a,krank,r)
c
c       extracts R in the QR decomposition specified by the output a
c       of the routine idzr_qrpiv or idzp_qrpiv.
c
c       input:
c       m -- first dimension of a
c       n -- second dimension of a and r
c       a -- output of routine idzr_qrpiv or idzp_qrpiv
c       krank -- rank output by routine idzp_qrpiv (or specified
c                to routine idzr_qrpiv)
c
c       output:
c       r -- triangular factor in the QR decomposition specified
c            by the output a of the routine idzr_qrpiv or idzp_qrpiv
c
        implicit none
        integer m,n,j,k,krank
        complex*16 a(m,n),r(krank,n)
c
c
c       Copy a into r and zero out the appropriate
c       Householder vectors that are stored in one triangle of a.
c
        do k = 1,n
          do j = 1,krank
            r(j,k) = a(j,k)
          enddo ! j
        enddo ! k
c
        do k = 1,n
          if(k .lt. krank) then
            do j = k+1,krank
              r(j,k) = 0
            enddo ! j
          endif
        enddo ! k
c
c
        return
        end


module nr_utility_module
USE nrtype
! contains functions that should really be part of the fortran standard, but are not
implicit none
INTERFACE arth
! MODULE PROCEDURE arth_r,arth_d, arth_i
!Hack by SVK
 MODULE PROCEDURE arth_d, arth_i
END INTERFACE
! (everything private unless otherwise specifed)
private
! build vectors of regularly spaced numbers
public::arth
contains

 ! *************************************************************************************************
 ! * the arth function, used to build a vector of regularly spaced numbers
 ! *************************************************************************************************
#if 0
 FUNCTION arth_r(first,increment,n)
 implicit none
 REAL(SP), INTENT(IN) :: first,increment
 INTEGER(I4B), INTENT(IN) :: n
 REAL(SP), DIMENSION(n) :: arth_r
 INTEGER(I4B) :: k
 arth_r(1)=first
 if(n>1)then
  do k=2,n
   arth_r(k) = arth_r(k-1) + increment
  end do
 end if
 END FUNCTION arth_r
#endif
 ! ------------------------------------------------------------------------------------------------
 FUNCTION arth_d(first,increment,n)
 implicit none
 REAL(DP), INTENT(IN) :: first,increment
 INTEGER(I4B), INTENT(IN) :: n
 REAL(DP), DIMENSION(n) :: arth_d
 INTEGER(I4B) :: k
 arth_d(1)=first
 if(n>1)then
  do k=2,n
   arth_d(k) = arth_d(k-1) + increment
  end do
 end if
 END FUNCTION arth_d
 ! ------------------------------------------------------------------------------------------------
 FUNCTION arth_i(first,increment,n)
 implicit none
 INTEGER(I4B), INTENT(IN) :: first,increment,n
 INTEGER(I4B), DIMENSION(n) :: arth_i
 INTEGER(I4B) :: k
 arth_i(1)=first
 if(n>1)then
  do k=2,n
   arth_i(k) = arth_i(k-1) + increment
  end do
 end if
 END FUNCTION arth_i

end module nr_utility_module


!---------------------------------------------------------------------!
!                                PHAML                                !
!                                                                     !
! The Parallel Hierarchical Adaptive MultiLevel code for solving      !
! linear elliptic partial differential equations of the form          !
! (PUx)x + (QUy)y + RU = F on 2D polygonal domains with mixed         !
! boundary conditions, and eigenvalue problems where F is lambda*U.   !
!                                                                     !
! PHAML is public domain software.  It was produced as part of work   !
! done by the U.S. Government, and is not subject to copyright in     !
! the United States.                                                  !
!                                                                     !
!     William F. Mitchell                                             !
!     Applied and Computational Mathematics Division                  !
!     National Institute of Standards and Technology                  !
!     william.mitchell@nist.gov                                       !
!     http://math.nist.gov/phaml                                      !
!                                                                     !
!---------------------------------------------------------------------!

!----------------------------------------------------
! This file contains the user supplied external subroutines that define
! the PDE(s) to be solved, and other required external subroutines.
!   pdecoefs bconds boundary_point boundary_npiece boundary_param iconds trues
!   truexs trueys update_usermod phaml_integral_kernel
!
! This version illustrates several scalar linear elliptic PDEs.
!----------------------------------------------------

!          --------
subroutine pdecoefs(x,y,cxx,cxy,cyy,cx,cy,c,rs)
!          --------

!----------------------------------------------------
! This subroutine returns the coefficient and right hand side of the PDE
! at the point (x,y)
!
! The PDE is
!
!    -( cxx(x,y) * u  )  -( cyy(x,y) * u  ) + c(x,y) * u = rs(x,y)
!                   x  x                y  y
!
! For eigenvalue problems, the right hand side is lambda * u * rs(x,y)
!
! cxy, cx and cy are not currently used and should not be set.  They are
! for future expansion.
!
! NOTE: BE CAREFUL TO GET THE SIGNS RIGHT
! e.g. cxx=cyy=1 means rs=-(uxx+uyy)
!
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
use phaml_user_mod
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x,y
real(my_real), intent(out) :: cxx(:,:),cxy(:,:),cyy(:,:),cx(:,:),cy(:,:), &
                              c(:,:),rs(:)
!----------------------------------------------------

!----------------------------------------------------
! Local variables

real(my_real) :: e,a,t,tx,ty,txx,tyy,px,qy,rp117,rp5,r1,r2,r117,r500,r1000, &
                 r2000,r,dcxydx
!----------------------------------------------------
! Non-module procedures used are:

interface

   function trues(x,y,comp,eigen) ! real (my_real)
   use phaml
   real (my_real), intent(in) :: x,y
   integer, intent(in) :: comp,eigen
   real (my_real) :: trues
   end function trues

   function truexs(x,y,comp,eigen) ! real (my_real)
   use phaml
   real (my_real), intent(in) :: x,y
   integer, intent(in) :: comp,eigen
   real (my_real) :: truexs
   end function truexs

   function trueys(x,y,comp,eigen) ! real (my_real)
   use phaml
   real (my_real), intent(in) :: x,y
   integer, intent(in) :: comp,eigen
   real (my_real) :: trueys
   end function trueys

end interface

!----------------------------------------------------
! Begin executable code

cxy=0; cx=0; cy=0

select case (choice)

   case (1,2,3,4,5) ! Laplace problems
      cxx = 1.0_my_real
      cyy = 1.0_my_real
      c = 0.0_my_real
      rs = 0.0_my_real

   case (6,8) ! x**ipower+y**ipower
      cxx = 1.0_my_real
      cyy = 1.0_my_real
      c = 0.0_my_real
      rs = -ipower*(ipower-1)*(x**(ipower-2)+y**(ipower-2))

   case (7) ! peak
      cxx = 1.0_my_real
      cyy = 1.0_my_real
      c = 0.0_my_real
      rp117 = 0.117_my_real
      rp5 = 0.5_my_real
      r1 = 1.0_my_real
      r2 = 2.0_my_real
      r117 = 117.0_my_real
      r500 = 500.0_my_real
      r1000 = 1000.0_my_real
      r2000 = 2000.0_my_real
      e = exp(-r500*((x-rp5)**2+(y-rp117)**2))
      rs = -e*(-r2*y*(r1-y)+r2*(r1-x)*y*(r1-y)*(-r1000*x+r500)               &
           -r2*x*y*(r1-y)*(-r1000*x+r500)-r2000*x*(r1-x)*y*(r1-y)            &
           +x*(r1-x)*y*(r1-y)*(-r1000*x+r500)**2 -r2*x*(r1-x)                &
           +r2*x*(r1-x)*(r1-y)*(-r1000*y+r117)-r2*x*(r1-x)*y*(-r1000*y+r117) &
           +x*(r1-x)*y*(r1-y)*(-r1000*y+r117)**2)

   case (9) ! nonconstant coefficients
      cxx = 1 + x*x
      a = 4.0_my_real*y*y + 0.9_my_real
      cyy = 1 + a*a
      c = -(1.0_my_real+(8.0_my_real*y-x-4.0_my_real)**2)
      t = trues(x,y,1,1)
      tx = cos(x)*sin(y)
      ty = sin(x)*cos(y)
      txx = -sin(x)*sin(y)
      tyy = -sin(x)*sin(y)
      px = 2.0_my_real*x
      qy = 2.0_my_real*a*8.0_my_real*y
      rs = -cxx(1,1)*txx-px*tx -cyy(1,1)*tyy-qy*ty  +c(1,1)*t

   case (10) ! x(1-x)y(1-y)
      cxx = 1.0_my_real
      cyy = 1.0_my_real
      c = 0.0_my_real
      rs = 2.0_my_real*(x*(1.0_my_real-x)+y*(1.0_my_real-y))

   case (11) ! Helmholtz
      cxx = 1.0_my_real
      cyy = 1.0_my_real
      c = -prob_param**2
      rs = 0.0_my_real

   case (12) ! Poisson with same solution as case 11
      cxx = 1.0_my_real
      cyy = 1.0_my_real
      c = 0.0_my_real
      rs = prob_param**2 * trues(x,y,1,1)

   case (13) ! sin(prob_param*r)
      cxx = 1.0_my_real
      cyy = 1.0_my_real
      c = 0.0_my_real
      r = prob_param*sqrt(x**2+y**2)
      rs = prob_param**2*(sin(r) -cos(r)/r)

   case (14) ! x**ipower+y**ipower with Helmholtz
      cxx = 1.0_my_real
      cyy = 1.0_my_real
      c = prob_param
      rs = -ipower*(ipower-1)*(x**(ipower-2)+y**(ipower-2)) + &
            prob_param * (x**ipower + y**ipower)

   case (15) ! tanh wave front
      cxx = 1.0_my_real
      cyy = 1.0_my_real
      c = 0.0_my_real
      r = prob_param*(x**2 + y**2 - .5)
      rs = -4*prob_param/cosh(r)**2 + &
            8*prob_param**2*(x**2+y**2)*tanh(r)/cosh(r)**2

   case (16) ! mock eigenvalue problem
      cxx = 1.0_my_real
      cyy = 1.0_my_real
      c = 0.5_my_real*prob_param*(x*x+3.0_my_real*y*y)
      rs = sqrt(prob_param*(2.0_my_real+sqrt(3.0_my_real)))*trues(x,y,1,1)

   case (17) ! first order terms
      cxx = 1.0_my_real
      cyy = 1.0_my_real
      cx = 1  + x*(1-x) + y*(1-y)
      cy = 1  + x*(1-x) + y*(1-y)
      c = 0.0_my_real
      rs = -ipower*(ipower-1)*(x**(ipower-2)+y**(ipower-2)) &
           + cx(1,1)*truexs(x,y,1,1) + cy(1,1)*trueys(x,y,1,1)

   case (18) ! mixed derivative term
      cxx = 1.0_my_real
      cyy = 1.0_my_real
      cxy = 1+x*(1-y)
      dcxydx = (1-y)
      c = 0.0_my_real
      rs = -ipower*(ipower-1)*(x**(ipower-2)*y**ipower+x**ipower*y**(ipower-2))&
           - cxy(1,1)*ipower**2*x**(ipower-1)*y**(ipower-1) &
           - dcxydx*ipower*x**ipower*y**(ipower-1)

   case default
      print *,"ERROR -- pdecoefs called with unknown problem id"
      stop

end select

end subroutine pdecoefs

!          ------
subroutine bconds(x,y,bmark,itype,c,rs)
!          ------

!----------------------------------------------------
! This subroutine returns the boundary conditions at the point (x,y).
!
! Each boundary condition is either
!
!    u = rs(x,y) or  u  + c(x,y)*u = rs(x,y)
!                     n
!
! itype indicates which type of condition applies to each point, using
! symbolic constants from module phaml.  It is DIRICHLET for the first
! condition, NATURAL for the second condition with c==0, and MIXED for
! the second condition with c/=0.
!
! bmark is assumed to give the following values for the unit square:
!  1 - lower left corner
!  2 - left side
!  3 - upper left corner
!  4 - top
!  5 - upper right corner
!  6 - right side
!  7 - lower right corner
!  8 - bottom
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
use phaml_user_mod
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x,y
integer, intent(in) :: bmark
integer, intent(out) :: itype(:)
real(my_real), intent(out) :: c(:,:),rs(:)
!----------------------------------------------------

!----------------------------------------------------
! Non-module procedures used are:

interface

   function trues(x,y,comp,eigen) ! real (my_real)
   use phaml
   real (my_real), intent(in) :: x,y
   integer, intent(in) :: comp,eigen
   real (my_real) :: trues
   end function trues

end interface

!----------------------------------------------------
! Local variables

!----------------------------------------------------

!----------------------------------------------------
! Begin executable code

select case (choice)

   case (1,2,3,6,7,9,10,11,12,13,14,15,16,17,18) ! DIRICHLET known solutions, use trues
      itype = DIRICHLET
      c = 0.0_my_real
      rs = trues(x,y,1,1)

   case (4) ! unknown solution
      itype = DIRICHLET
      c = 0.0_my_real
      select case (bmark)
         case (3,4,5) ! top
            rs = x*x*(1.0_my_real-x)*(1.0_my_real-x)
         case default
            rs = 0.0_my_real
      end select

   case (5) ! unknown solution
      itype = DIRICHLET
      c = 0.0_my_real
      select case (bmark)
         case (3,4,5) ! top
            if (x < prob_param) then
               rs = x/prob_param
            else
               rs = (1.0_my_real-x)/(1.0_my_real-prob_param)
            endif
         case default
            rs = 0.0_my_real
      end select

   case (8) ! natural and mixed conditions
      select case (bmark)
         case (2,3) ! left side
            itype = NATURAL
            c = 0.0_my_real
            if (ipower == 1) then
               rs = -1.0_my_real
            else
               rs = 0.0_my_real
            endif
         case (4) ! top
            itype = MIXED
            c = x
            rs = ipower*y**(ipower-1) + c(1,1)*trues(x,y,1,1)
         case (5,6) ! right side
            itype = NATURAL
            c = 0.0_my_real
            rs = ipower*x**(ipower-1)
         case (7,8,1) ! bottom
            itype = DIRICHLET
            c = 0.0_my_real
            rs = trues(x,y,1,1)
         case default
            print *,"ERROR -- bconds called with invalid bmark ",bmark
            stop
      end select

   case default
      print *,"ERROR -- bconds called with unknown problem id"
      stop

end select

end subroutine bconds

!        ------
function iconds(x,y,comp,eigen)
!        ------

!----------------------------------------------------
! This routine returns the initial condition for a time dependent problem.
! It can also be used for the initial guess for a nonlinear problem, or
! systems of equations solved by sucessive substitution.
! comp,eigen is which solution to use from a coupled system of PDEs or multiple
! eigenvectors from an eigenvalue problem, and is ignored in this example.
! For problems where there are no initial conditions, it is a dummy.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real(my_real) :: iconds

!----------------------------------------------------
! Begin executable code

iconds = 0.0_my_real

end function iconds

!        -----
function trues(x,y,comp,eigen) ! real (my_real)
!        -----

!----------------------------------------------------
! This is the true solution of the differential equation, if known.
! comp,eigen is which solution to use from a coupled system of PDEs or multiple
! eigenvectors from an eigenvalue problem, and is ignored in this example.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
use phaml_user_mod
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real (my_real) :: trues
!----------------------------------------------------
! Local variables

real (my_real) :: p,q,pi,r,theta1
!----------------------------------------------------
! Begin executable code

select case (choice)

   case (1) ! x+y
      trues = x+y

   case (2) ! something more complicated but still
            ! satisfies Laplace's equation
      p=x**4-6.0_my_real*x**2*y**2+y**4
      q=x**8-28.0_my_real*x**6*y**2+70.0_my_real*x**4*y**4-28.0_my_real*x**2*y**6+y**8
      trues = 1.1786_my_real-0.1801_my_real*p+0.006_my_real*q

   case (3) ! singularity at the origin, from the L domain problem
      pi=4.0_my_real*atan(1.0_my_real)
      r = sqrt(x*x+y*y)
      if (x.eq.0.0_my_real) then
         if(y.gt.0.0_my_real) then
            theta1=pi/2.0_my_real
         else
            theta1=3.0_my_real*pi/2.0_my_real
         endif
      else
         if (x.gt.0.0_my_real) then
            if(y.ge.00_my_real) then
              theta1=atan(y/x)
            else
              theta1=atan(y/x)+2.0_my_real*pi
            endif
         else
            theta1=atan(y/x)+pi
         endif
      endif
      trues = r**(2.0_my_real/3.0_my_real)*sin(2.0_my_real*theta1/3.0_my_real)

   case (6,8,14,17) ! x**ipower+y**ipower
      trues = x**ipower + y**ipower

   case (7) ! peak
      trues = x*(1.0_my_real-x)*y*(1.0_my_real-y)* &
              exp(-500.0_my_real*((x-0.5_my_real)**2+(y-0.117_my_real)**2))

   case (4,5) ! unknown
      trues = huge(0.0_my_real)

   case (9) ! simpler than R&B #54
      trues = sin(x)*sin(y)

   case (10) ! x(1-x)y(1-y)
      trues = x*(1.0_my_real-x)*y*(1.0_my_real-y)

   case (11,12)
      trues = sin(prob_param*x) + sin(prob_param*y)

   case (13)
      trues = sin(prob_param*sqrt(x**2+y**2))

   case (15) ! tanh wave front
      trues = tanh(prob_param*(x**2+y**2-.5))

   case (16) ! mock eigenvalue problem, first eigenfunction
      trues = exp(-sqrt(prob_param/8)*(x*x+sqrt(3.0_my_real)*y*y))

   case (18) ! x**ipower*y**ipower
      trues = x**ipower * y**ipower

   case default
      print *,"ERROR -- trues called with unknown problem id"
      stop

end select

end function trues

!        ------
function truexs(x,y,comp,eigen) ! real (my_real)
!        ------

!----------------------------------------------------
! This is the x derivative of the true solution of the differential equation,
! if known.
! comp,eigen is which solution to use from a coupled system of PDEs or multiple
! eigenvectors from an eigenvalue problem, and is ignored in this example.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
use phaml_user_mod
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real (my_real) :: truexs
!----------------------------------------------------
! Local variables

real (my_real) :: p,q,pi,r,theta1
!----------------------------------------------------
! Begin executable code

select case (choice)

   case (6,8,14,17) ! x**ipower+y**ipower

      truexs = ipower*x**(ipower-1)

   case (9) ! simpler than R&B #54
      truexs = cos(x)*sin(y)

   case (10) ! x(1-x)y(1-y)
      truexs = (1.0_my_real-2.0_my_real*x)*y*(1.0_my_real-y)

   case (11,12) ! sin(a*x) + sin(a*y)
      truexs = prob_param*cos(prob_param*x)

   case (15) ! tanh wave front
      truexs = 2*prob_param*x/cosh(prob_param*(x**2+y**2-.5))**2

   case (16) ! mock eigenvalue problem, first eigenfunction
      truexs = exp(-sqrt(prob_param/8)*(x*x+sqrt(3.0_my_real)*y*y))
      truexs = -2*sqrt(prob_param/8)*x*truexs

   case (18) ! x**ipower*y**ipower
      truexs = ipower*x**(ipower-1) * y**ipower

   case default

      truexs = huge(0.0_my_real)

end select

end function truexs

!        ------
function trueys(x,y,comp,eigen) ! real (my_real)
!        ------

!----------------------------------------------------
! This is the y derivative of the true solution of the differential equation,
! if known.
! comp,eigen is which solution to use from a coupled system of PDEs or multiple
! eigenvectors from an eigenvalue problem, and is ignored in this example.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
use phaml_user_mod
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real (my_real) :: trueys
!----------------------------------------------------
! Local variables

real (my_real) :: p,q,pi,r,theta1
!----------------------------------------------------
! Begin executable code

select case (choice)

   case (6,8,14,17) ! x**ipower+y**ipower

      trueys = ipower*y**(ipower-1)

   case (9) ! simpler than R&B #54
      trueys = sin(x)*cos(y)

   case (10) ! x(1-x)y(1-y)
      trueys = (1.0_my_real-2.0_my_real*y)*x*(1.0_my_real-x)

   case (11,12) ! sin(a*x) + sin(a*y)
      trueys = prob_param*cos(prob_param*y)

   case (15) ! tanh wave front
      trueys = 2*prob_param*y/cosh(prob_param*(x**2+y**2-.5))**2

   case (16) ! mock eigenvalue problem, first eigenfunction
      trueys = exp(-sqrt(prob_param/8)*(x*x+sqrt(3.0_my_real)*y*y))
      trueys = -2*sqrt(3.0_my_real)*sqrt(prob_param/8)*y*trueys

   case (18) ! x**ipower*y**ipower
      trueys = ipower*y**(ipower-1) * x**ipower

   case default

      trueys = huge(0.0_my_real)

end select

end function trueys

!          --------------
subroutine boundary_point(ipiece,s,x,y)
!          --------------

!----------------------------------------------------
! This routine defines the boundary of the domain.  It returns the point
! (x,y) with parameter s on piece ipiece.
! If boundary_npiece <= 0 it is a dummy and the domain is given by triangle
! data files.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

integer, intent(in) :: ipiece
real(my_real), intent(in) :: s
real(my_real), intent(out) :: x,y

!----------------------------------------------------
! Begin executable code

! Dummy version

x = 0.0_my_real
y = 0.0_my_real

end subroutine boundary_point

!        ---------------
function boundary_npiece(hole)
!        ---------------

!----------------------------------------------------
! This routine gives the number of pieces in the boundary definition.
! If boundary_npiece <= 0 the domain is given by triangle data files.
!----------------------------------------------------

!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

integer, intent(in) :: hole
integer :: boundary_npiece
!----------------------------------------------------
! Begin executable code

boundary_npiece = 0

end function boundary_npiece

!          --------------
subroutine boundary_param(start,finish)
!          --------------

!----------------------------------------------------
! This routine gives the range of parameter values for each piece of the
! boundary.
! If boundary_npiece <= 0 it is a dummy and the domain is given by triangle
! data files.
!----------------------------------------------------

!----------------------------------------------------
! Modules used are:

use phaml
!----------------------------------------------------

implicit none

!----------------------------------------------------
! Dummy arguments

real(my_real), intent(out) :: start(:), finish(:)
!----------------------------------------------------
! Begin executable code

! Dummy version

start = 0.0_my_real
finish = 0.0_my_real

end subroutine boundary_param

!          --------------
subroutine update_usermod(phaml_solution)
!          --------------

!----------------------------------------------------
! This routine updates the module variables on the slave processes by
! sending them from the master process
!----------------------------------------------------

use phaml
use phaml_user_mod

!----------------------------------------------------
! Dummy arguments

type(phaml_solution_type), intent(in) :: phaml_solution

!----------------------------------------------------
! Local variables:

! Declare these arrays big enough to hold the variables to be sent

integer :: iparam(1)
real(my_real) :: rparam(1)

!----------------------------------------------------
! Begin executable code

! Copy the module variables into the arrays, putting integer variables
! into iparam and real variables into rparam.

   iparam(1) = ipower
   rparam(1) = prob_param

! Call the routine that performs the actual exchange.  Don't change this line.

   call master_to_slaves(phaml_solution,iparam,rparam)

! Copy the arrays into the module variables, using the same correspondence
! between module variable and array index as was used above.

   ipower = iparam(1)
   prob_param = rparam(1)

end subroutine update_usermod

!        ---------------------
function phaml_integral_kernel(kernel,x,y)
!        ---------------------

use phaml
integer, intent(in) :: kernel
real(my_real), intent(in) :: x,y
real(my_real) :: phaml_integral_kernel

! Identity function

phaml_integral_kernel = 1.0

end function phaml_integral_kernel

!        ----------
function regularity(x,y)
!        ----------

use phaml
real(my_real), intent(in) :: x(3),y(3)
real(my_real) :: regularity

! Dummy version, assume infinitely differentiable everywhere.

regularity = huge(0.0_my_real)

end function regularity


      double precision function  fdisc(blockno,xc,yc)
      implicit none

      double precision xc,yc, xp, yp, zp
      integer blockno
      integer*8 cont, get_context

      double precision pi, pi2
      common /compi/ pi, pi2

      double precision beta, theta(2)
      common /annulus_comm/ beta, theta

      double precision init_radius
      common /initradius_comm/ init_radius

      double precision x0, y0, r0, r, ravg, th

      cont = get_context()

      call fclaw2d_map_c2m(cont,
     &      blockno,xc,yc,xp,yp,zp)

      ravg = (1 + beta)/2.d0
      th = pi2*(0.25 + 1.d0/32.d0)
      x0 = ravg*cos(th)
      y0 = ravg*sin(th)

      r = sqrt((xp - x0)**2 + (yp-y0)**2)

      r0 = init_radius
      fdisc = r - r0

      end


SUBROUTINE formkc(bk,km,cm,g,n)
!global stiffness matrix stored as a vector (upper triangle); complex
IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
REAL(iwp),INTENT(in)::km(:,:),cm(:,:);COMPLEX(iwp),INTENT(out)::bk(:)
INTEGER,INTENT(IN)::g(:),n
INTEGER::idof,i,j,icd,ival
idof=SIZE(km,1)
     DO i=1,idof
        IF(g(i)/=0) THEN
           DO j=1,idof
              IF(g(j)/=0) THEN
                 icd=g(j)-g(i)+1
                 IF(icd-1>=0) THEN
                    ival=n*(icd-1)+g(i)
                    bk(ival)=bk(ival)+CMPLX(km(i,j),cm(i,j))
                 END IF
               END IF
            END DO
         END IF
     END DO
RETURN
END SUBROUTINE FORMKC


c-----------------------------------------------------------------------
      subroutine ilud(n,a,ja,ia,alph,tol,alu,jlu,ju,iwk,w,jw,ierr)
c-----------------------------------------------------------------------
      implicit none
      integer n,ja(*),ia(n+1),jlu(*),ju(n),jw(2*n),iwk,ierr
      real*8 a(*),alu(*),w(2*n),tol, alph

c----------------------------------------------------------------------*
c                     *** ILUD preconditioner ***                      *
c    incomplete LU factorization with standard droppoing strategy      *
c----------------------------------------------------------------------*
c Author: Yousef Saad * Aug. 1995 --                                   *
c----------------------------------------------------------------------*
c This routine computes the ILU factorization with standard threshold  *
c dropping: at i-th step of elimination, an element a(i,j) in row i is *
c dropped  if it satisfies the criterion:                              *
c                                                                      *
c  abs(a(i,j)) < tol * [average magnitude of elements in row i of A]   *
c                                                                      *
c There is no control on memory size required for the factors as is    *
c done in ILUT. This routines computes also various diagonal compensa- *
c tion ILU's such MILU. These are defined through the parameter alph   *
c----------------------------------------------------------------------*
c on entry:
c==========
c n       = integer. The row dimension of the matrix A. The matrix
c
c a,ja,ia = matrix stored in Compressed Sparse Row format
c
c alph    = diagonal compensation parameter -- the term:
c
c           alph*(sum of all dropped out elements in a given row)
c
c           is added to the diagonal element of U of the factorization
c           Thus: alph = 0 ---> ~ ILU with threshold,
c                 alph = 1 ---> ~ MILU with threshold.
c
c tol     = Threshold parameter for dropping small terms in the
c           factorization. During the elimination, a term a(i,j) is
c           dropped whenever abs(a(i,j)) .lt. tol * [weighted norm of
c           row i]. Here weighted norm = 1-norm / number of nnz
c           elements in the row.
c
c iwk     = The length of arrays alu and jlu -- this routine will stop
c           if storage for the factors L and U is not sufficient
c
c On return:
c===========
c
c alu,jlu = matrix stored in Modified Sparse Row (MSR) format containing
c           the L and U factors together. The diagonal (stored in
c           alu(1:n) ) is inverted. Each i-th row of the alu,jlu matrix
c           contains the i-th row of L (excluding the diagonal entry=1)
c           followed by the i-th row of U.
c
c ju      = integer array of length n containing the pointers to
c           the beginning of each row of U in the matrix alu,jlu.
c
c ierr    = integer. Error message with the following meaning.
c           ierr  = 0    --> successful return.
c           ierr .gt. 0  --> zero pivot encountered at step number ierr.
c           ierr  = -1   --> Error. input matrix may be wrong.
c                            (The elimination process has generated a
c                            row in L or U whose length is .gt.  n.)
c           ierr  = -2   --> Insufficient storage for the LU factors --
c                            arrays alu/ jalu are  overflowed.
c           ierr  = -3   --> Zero row encountered.
c
c Work Arrays:
c=============
c jw      = integer work array of length 2*n.
c w       = real work array of length n
c
c----------------------------------------------------------------------
c
c w, ju (1:n) store the working array [1:ii-1 = L-part, ii:n = u]
c jw(n+1:2n)  stores the nonzero indicator.
c
c Notes:
c ------
c All diagonal elements of the input matrix must be  nonzero.
c
c-----------------------------------------------------------------------
c     locals
      integer ju0,k,j1,j2,j,ii,i,lenl,lenu,jj,jrow,jpos,len
      real*8 tnorm, t, abs, s, fact, dropsum
c-----------------------------------------------------------------------
c     initialize ju0 (points to next element to be added to alu,jlu)
c     and pointer array.
c-----------------------------------------------------------------------
      ju0 = n+2
      jlu(1) = ju0
c
c     initialize nonzero indicator array.
c
      do 1 j=1,n
         jw(n+j)  = 0
 1    continue
c-----------------------------------------------------------------------
c     beginning of main loop.
c-----------------------------------------------------------------------
      do 500 ii = 1, n
         j1 = ia(ii)
         j2 = ia(ii+1) - 1
         dropsum = 0.0d0
         tnorm = 0.0d0
         do 501 k=j1,j2
            tnorm = tnorm + abs(a(k))
 501     continue
         if (tnorm .eq. 0.0) goto 997
         tnorm = tnorm / real(j2-j1+1)
c
c     unpack L-part and U-part of row of A in arrays w
c
         lenu = 1
         lenl = 0
         jw(ii) = ii
         w(ii) = 0.0
         jw(n+ii) = ii
c
         do 170  j = j1, j2
            k = ja(j)
            t = a(j)
            if (k .lt. ii) then
               lenl = lenl+1
               jw(lenl) = k
               w(lenl) = t
               jw(n+k) = lenl
            else if (k .eq. ii) then
               w(ii) = t
            else
               lenu = lenu+1
               jpos = ii+lenu-1
               jw(jpos) = k
               w(jpos) = t
               jw(n+k) = jpos
            endif
 170     continue
         jj = 0
         len = 0
c
c     eliminate previous rows
c
 150     jj = jj+1
         if (jj .gt. lenl) goto 160
c-----------------------------------------------------------------------
c     in order to do the elimination in the correct order we must select
c     the smallest column index among jw(k), k=jj+1, ..., lenl.
c-----------------------------------------------------------------------
         jrow = jw(jj)
         k = jj
c
c     determine smallest column index
c
         do 151 j=jj+1,lenl
            if (jw(j) .lt. jrow) then
               jrow = jw(j)
               k = j
            endif
 151     continue
c
         if (k .ne. jj) then
c     exchange in jw
            j = jw(jj)
            jw(jj) = jw(k)
            jw(k) = j
c     exchange in jr
            jw(n+jrow) = jj
            jw(n+j) = k
c     exchange in w
            s = w(jj)
            w(jj) = w(k)
            w(k) = s
         endif
c
c     zero out element in row by setting resetting jw(n+jrow) to zero.
c
         jw(n+jrow) = 0
c
c     drop term if small
c
c         if (abs(w(jj)) .le. tol*tnorm) then
c            dropsum = dropsum + w(jj)
c            goto 150
c         endif
c
c     get the multiplier for row to be eliminated (jrow).
c
         fact = w(jj)*alu(jrow)
c
c     drop term if small
c
         if (abs(fact) .le. tol) then
            dropsum = dropsum + w(jj)
            goto 150
         endif
c
c     combine current row and row jrow
c
         do 203 k = ju(jrow), jlu(jrow+1)-1
            s = fact*alu(k)
            j = jlu(k)
            jpos = jw(n+j)
            if (j .ge. ii) then
c
c     dealing with upper part.
c
               if (jpos .eq. 0) then
c
c     this is a fill-in element
c
                  lenu = lenu+1
                  if (lenu .gt. n) goto 995
                  i = ii+lenu-1
                  jw(i) = j
                  jw(n+j) = i
                  w(i) = - s
               else
c
c     this is not a fill-in element
c
                  w(jpos) = w(jpos) - s
               endif
            else
c
c     dealing with lower part.
c
               if (jpos .eq. 0) then
c
c     this is a fill-in element
c
                  lenl = lenl+1
                  if (lenl .gt. n) goto 995
                  jw(lenl) = j
                  jw(n+j) = lenl
                  w(lenl) = - s
               else
c
c     this is not a fill-in element
c
                  w(jpos) = w(jpos) - s
               endif
            endif
 203     continue
         len = len+1
         w(len) = fact
         jw(len)  = jrow
         goto 150
 160     continue
c
c     reset double-pointer to zero (For U-part only)
c
         do 308 k=1, lenu
            jw(n+jw(ii+k-1)) = 0
 308     continue
c
c     update l-matrix
c
         do 204 k=1, len
            if (ju0 .gt. iwk) goto 996
            alu(ju0) =  w(k)
            jlu(ju0) =  jw(k)
            ju0 = ju0+1
 204     continue
c
c     save pointer to beginning of row ii of U
c
         ju(ii) = ju0
c
c     go through elements in U-part of w to determine elements to keep
c
         len = 0
         do 205 k=1, lenu-1
c            if (abs(w(ii+k)) .gt. tnorm*tol) then
            if (abs(w(ii+k)) .gt. abs(w(ii))*tol) then
               len = len+1
               w(ii+len) = w(ii+k)
               jw(ii+len) = jw(ii+k)
            else
               dropsum = dropsum + w(ii+k)
            endif
205      continue
c
c     now update u-matrix
c
         if (ju0 + len-1 .gt. iwk) goto 996
         do 302 k=ii+1,ii+len
            jlu(ju0) = jw(k)
            alu(ju0) = w(k)
            ju0 = ju0+1
 302     continue
c
c     define diagonal element
c
         w(ii) = w(ii) + alph*dropsum
c
c     store inverse of diagonal element of u
c
         if (w(ii) .eq. 0.0) w(ii) = (0.0001 + tol)*tnorm
c
         alu(ii) = 1.0d0/ w(ii)
c
c     update pointer to beginning of next row of U.
c
         jlu(ii+1) = ju0
c-----------------------------------------------------------------------
c     end main loop
c-----------------------------------------------------------------------
 500  continue
      ierr = 0
      return
c
c     incomprehensible error. Matrix must be wrong.
c
 995  ierr = -1
      return
c
c     insufficient storage in alu/ jlu arrays for  L / U factors
c
 996  ierr = -2
      return
c
c     zero row encountered
c
 997  ierr = -3
      return
c----------------end-of-ilud  ------------------------------------------
c-----------------------------------------------------------------------
      end


submodule (m_random) sm_rngGamma
  !! Generate random numbers from a gamma distribution.

  ! Original Version
  ! Author: Alan Miller

  ! Updated version:
  ! Version 2.00, 11 November 2016
  ! Increased precision to double
  !
  ! Updated again
  ! Added overloaded operations for single number, nD arrays
  !     Author: Leon Foks

implicit none

contains

  !====================================================================!
  module procedure rngGamma_d1!(this,s,first)
    !! Interfaced with [[rngGamma]]
  !====================================================================!
  !====================================================================!
  ! Adapted from Fortran 77 code from the book:
  !     Dagpunar, J. 'Principles of random variate generation'
  !     Clarendon Press, Oxford, 1988.   ISBN 0-19-852202-9

  !     FUNCTION GENERATES A RANDOM GAMMA VARIATE.
  !     CALLS EITHER random_gamma1 (S > 1.0)
  !     OR random_exponential (S = 1.0)
  !     OR random_gamma2 (S < 1.0).

  !     S = SHAPE PARAMETER OF DISTRIBUTION (0 < real(r64)).
  !====================================================================!
!  real(r64) :: this
!  real(r64), INTENT(IN)    :: s
!  LOGICAL, INTENT(IN) :: first

  IF (s <= zero) call Emsg('rngGamma : shape parameter must be positive')

  IF (s > one) THEN
    this = rngGamma1(s,first)
  ELSE IF (s < one) THEN
    this = rngGamma2(s,first)
  ELSE
    call rngExponential(this)
  END IF
  END procedure
  !====================================================================!
  !====================================================================!
  module procedure rngGamma_d1D!(this,s,first)
    !! Interfaced with [[rngGamma]]
  !====================================================================!
!  real(r64) :: this(:)
!  real(r64), INTENT(IN) :: s
!  LOGICAL, INTENT(IN) :: first
  integer :: i,N
  N=size(this)
  call rngGamma(this(1),s,first)
  do i=2,N
    call rngGamma(this(i),s,.false.)
  enddo
  end procedure
  !====================================================================!
  !====================================================================!
  function rngGamma1(s,first) result(this)
  !====================================================================!
  ! Uses the algorithm in
  ! Marsaglia, G. and Tsang, W.W. (2000) `A simple method for generating
  ! gamma variables', Trans. om Math. Software (TOMS), vol.26(3), pp.363-372.

  ! Generates a random gamma deviate for shape parameter s >= 1.
  real(r64) :: this
  real(r64), INTENT(IN)    :: s
  LOGICAL, INTENT(IN) :: first

  ! Local variables
  real(r64), SAVE  :: c, d
  real(r64)        :: u, v, x

  IF (first) THEN
    d = s - one/3.d0
    c = one/dSQRT(9.d0*d)
  END IF

  ! Start of main loop
  DO
    ! Generate v = (1+cx)^3 where x is random normal; repeat if v <= 0.
    DO
      call rngNormal(x)
      v = (one + c*x)**3.d0
      IF (v > zero) EXIT
    END DO

    ! Generate uniform variable U
    call rngUniform(u)
    IF (u < one - 0.0331d0*x**4.d0) THEN
      this = d*v
      EXIT
    ELSE IF (dLOG(u) < half*x**2.d0 + d*(one - v + dLOG(v))) THEN
      this = d*v
      EXIT
    END IF
  END DO
  END FUNCTION
  !====================================================================!
  !====================================================================!
  function rngGamma2(s,first) RESULT(this)
  !====================================================================!
  ! Adapted from Fortran 77 code from the book:
  !     Dagpunar, J. 'Principles of random variate generation'
  !     Clarendon Press, Oxford, 1988.   ISBN 0-19-852202-9

  ! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY) FROM
  ! A GAMMA DISTRIBUTION WITH DENSITY PROPORTIONAL TO
  ! GAMMA2**(S-1) * EXP(-GAMMA2),
  ! USING A SWITCHING METHOD.

  !    S = SHAPE PARAMETER OF DISTRIBUTION
  !          (real(r64) < 1.0)
  real(r64) :: this
  real(r64), INTENT(IN) :: s
  LOGICAL, INTENT(IN) :: first

  !     Local variables
  real(r64)       :: r, x, w
  real(r64), SAVE :: a, p, c, uf, vr, d

  IF (s <= zero .OR. s >= one) call Emsg('rngGamma2 : shape parameter outside (0 1)')

  IF (first) THEN                        ! Initialization, if necessary
    a = one - s
    p = a/(a + s*dEXP(-a))
    IF (s < vsmall) call Emsg('rngGamma2 : shape parameter too small')
    c = one/s
    uf = p*(vsmall/a)**s
    vr = one - vsmall
    d = a*dLOG(a)
  END IF

  DO
    CALL rngUniform(r)
    IF (r >= vr) THEN
      CYCLE
    ELSE IF (r > p) THEN
      x = a - dLOG((one - r)/(one - p))
      w = a*dLOG(x)-d
    ELSE IF (r > uf) THEN
      x = a*(r/p)**c
      w = x
    ELSE
      this = zero
      RETURN
    END IF

    CALL rngUniform(r)
    IF (one-r <= w .AND. r > zero) THEN
      IF (r*(w + one) >= one) CYCLE
      IF (-dLOG(r) <= w) CYCLE
    END IF
    EXIT
  END DO

  this = x
  END FUNCTION
  !====================================================================!

end submodule


SUBROUTINE gser(gamser,a,x,gln)
INTEGER ITMAX
REAL a,gamser,gln,x,EPS
PARAMETER (ITMAX=100,EPS=3.e-7)
!CU    USES gammln
INTEGER n
REAL ap,del,sum,gammln
gln=gammln(a)
if(x.le.0.)then
  if(x.lt.0.)pause 'x < 0 in gser'
  gamser=0.
  return
endif
ap=a
sum=1./a
del=sum
do n=1,ITMAX
  ap=ap+1.
  del=del*x/ap
  sum=sum+del
  if(abs(del).lt.abs(sum)*EPS)goto 1
enddo
pause 'a too large, ITMAX too small in gser'
1     gamser=sum*exp(-x+a*log(x)-gln)
return
END


module mod_map_functions
use iso_fortran_env,only:int8,int16,int32,int64,real32,real64,real128

implicit none

public

contains

pure integer(kind=int8) function xpowx_i1(x) result(res)
  integer(kind=int8),intent(in) :: x
  res = x**x
endfunction xpowx_i1

pure integer(kind=int16) function xpowx_i2(x) result(res)
  integer(kind=int16),intent(in) :: x
  res = x**x
endfunction xpowx_i2

pure integer(kind=int32) function xpowx_i4(x) result(res)
  integer(kind=int32),intent(in) :: x
  res = x**x
endfunction xpowx_i4

pure integer(kind=int64) function xpowx_i8(x) result(res)
  integer(kind=int64),intent(in) :: x
  res = x**x
endfunction xpowx_i8

pure real(kind=real32) function xpowx_r4(x) result(res)
  real(kind=real32),intent(in) :: x
  res = x**x
endfunction xpowx_r4

pure real(kind=real64) function xpowx_r8(x) result(res)
  real(kind=real64),intent(in) :: x
  res = x**x
endfunction xpowx_r8

pure real(kind=real128) function xpowx_r16(x) result(res)
  real(kind=real128),intent(in) :: x
  res = x**x
endfunction xpowx_r16

pure complex(kind=real32) function xpowx_c4(x) result(res)
  complex(kind=real32),intent(in) :: x
  res = x**x
endfunction xpowx_c4

pure complex(kind=real64) function xpowx_c8(x) result(res)
  complex(kind=real64),intent(in) :: x
  res = x**x
endfunction xpowx_c8

pure complex(kind=real128) function xpowx_c16(x) result(res)
  complex(kind=real128),intent(in) :: x
  res = x**x
endfunction xpowx_c16

endmodule mod_map_functions

program test_map
use iso_fortran_env,only:int8,int16,int32,int64,real32,real64,real128
use mod_testing,only:assert,initialize_tests,report_tests
use mod_functional
use mod_map_functions

implicit none

logical,dimension(:),allocatable :: tests
logical :: test_failed
integer :: n,norder,ntests
integer,parameter :: stdout = 6

complex(kind=real32),dimension(:),allocatable :: c4
complex(kind=real64),dimension(:),allocatable :: c8
complex(kind=real128),dimension(:),allocatable :: c16

n = 1
ntests = 10
call initialize_tests(tests,ntests)

tests(n) = assert(all(map(xpowx_i1,[1_int8,2_int8,3_int8])&
  == [1_int8,4_int8,27_int8]),'map, int8')
n = n + 1

tests(n) = assert(all(map(xpowx_i2,[1_int16,2_int16,3_int16])&
  == [1_int16,4_int16,27_int16]),'map, int16')
n = n + 1

tests(n) = assert(all(map(xpowx_i4,[1_int32,2_int32,3_int32])&
  == [1_int32,4_int32,27_int32]),'map, int32')
n = n + 1

tests(n) = assert(all(map(xpowx_i8,[1_int64,2_int64,3_int64])&
  == [1_int64,4_int64,27_int64]),'map, int64')
n = n + 1

tests(n) = assert(all(map(xpowx_r4,[1._real32,2._real32,3._real32])&
  == [1._real32,4._real32,27._real32]),'map, real32')
n = n + 1

tests(n) = assert(all(map(xpowx_r8,[1._real64,2._real64,3._real64])&
  == [1._real64,4._real64,27._real64]),'map, real64')
n = n + 1

tests(n) = assert(all(map(xpowx_r16,[1._real128,2._real128,3._real128])&
  == [1._real128,4._real128,27._real128]),'map, real128')
n = n + 1

c4 = [cmplx(1.,0.),cmplx(2.,0.),cmplx(3.,0.)]
c8 = [cmplx(1._real64,0._real64),&
      cmplx(2._real64,0._real64),&
      cmplx(3._real64,0._real64)]
c16 = [cmplx(1._real128,0._real128),&
       cmplx(2._real128,0._real128),&
       cmplx(3._real128,0._real128)]

tests(n) = assert(all(map(xpowx_c4,c4) == c4**c4),'map, complex real32')
n = n + 1

tests(n) = assert(all(map(xpowx_c8,c8) == c8**c8),'map, complex real64')
n = n + 1

tests(n) = assert(all(map(xpowx_c16,c16) == c16**c16),'map, complex real128')
n = n + 1

test_failed = .false.
call report_tests(tests,test_failed)
if(test_failed)stop 1

endprogram test_map


\ http://sametwice.com/8_line_mandelbrot
\ 8 line mandelbrot
fvariable ci fvariable c fvariable zi fvariable z
: f> f< not ;
: >2? z f@ fdup f* zi f@ fdup f* f+ 4.0e f> ;
: nextr z f@ fdup f* zi f@ fdup f* f- c f@ f+ ;
: nexti z f@ zi f@ f* 2.0e f* ci f@ f+ ;
: pixel c f! ci f! 0e z f! 0e zi f! 150 50 do nextr nexti zi f! z f! >2? if i unloop exit then loop bl ;
: left->right -1.5e 80 0 do fover fover pixel emit 0.026e f+ loop fdrop ;
: top->bottom -1e 40 0 do left->right cr 0.05e f+ loop fdrop ;
top->bottom \  bye


	program main
	include 'mpif.h'
	integer count, errcnt, size, rank, ierr, i
	integer comm
	logical fnderr
	integer max_size
	integer world_rank
	parameter (max_size=100)
	integer intin(max_size), intout(max_size), intsol(max_size)
	real    realin(max_size), realout(max_size), realsol(max_size)
	double precision dblein(max_size), dbleout(max_size),
     *                   dblesol(max_size)
	complex cplxin(max_size), cplxout(max_size), cplxsol(max_size)
	logical login(max_size), logout(max_size), logsol(max_size)
C
C
C
C       Declare work areas
C
	call MPI_INIT( ierr )

	errcnt = 0
	comm = MPI_COMM_WORLD
	call MPI_COMM_RANK( comm, rank, ierr )
	world_rank = rank
	call MPI_COMM_SIZE( comm, size, ierr )
	count = 10

C Test sum
	if (world_rank .eq. 0) print *, ' MPI_SUM'

       fnderr = .false.
       do 23000 i=1,count
	intin(i) = i
        intsol(i) = i*size
	intout(i) = 0
23000	continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_SUM, comm, ierr )
              do 23001 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23001	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_INTEGER and op MPI_SUM'
	endif

       fnderr = .false.
       do 23002 i=1,count
	realin(i) = i
        realsol(i) = i*size
	realout(i) = 0
23002	continue
       call MPI_Allreduce( realin, realout, count,
     *      MPI_REAL, MPI_SUM, comm, ierr )
              do 23003 i=1,count
        if (realout(i).ne.realsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23003	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_REAL and op MPI_SUM'
	endif

       fnderr = .false.
       do 23004 i=1,count
	dblein(i) = i
        dblesol(i) = i*size
	dbleout(i) = 0
23004	continue
       call MPI_Allreduce( dblein, dbleout, count,
     *      MPI_DOUBLE_PRECISION, MPI_SUM, comm, ierr )
              do 23005 i=1,count
        if (dbleout(i).ne.dblesol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23005	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_DOUBLE_PRECISION and op MPI_SUM'
	endif

       fnderr = .false.
       do 23006 i=1,count
	cplxin(i) = i
        cplxsol(i) = i*size
	cplxout(i) = 0
23006	continue
       call MPI_Allreduce( cplxin, cplxout, count,
     *      MPI_COMPLEX, MPI_SUM, comm, ierr )
              do 23007 i=1,count
        if (cplxout(i).ne.cplxsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23007	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_COMPLEX and op MPI_SUM'
	endif

	if (errcnt .gt. 0) then
	print *, 'Found ', errcnt, ' errors on ', rank, ' for MPI_SUM'
	endif
	errcnt = 0

C Test product
	if (world_rank .eq. 0) print *, ' MPI_PROD'

       fnderr = .false.
       do 23008 i=1,count
	intin(i) = i
        intsol(i) = (i)**(size)
	intout(i) = 0
23008	continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_PROD, comm, ierr )
              do 23009 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23009	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_INTEGER and op MPI_PROD'
	endif

       fnderr = .false.
       do 23010 i=1,count
	realin(i) = i
        realsol(i) = (i)**(size)
	realout(i) = 0
23010	continue
       call MPI_Allreduce( realin, realout, count,
     *      MPI_REAL, MPI_PROD, comm, ierr )
              do 23011 i=1,count
        if (realout(i).ne.realsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23011	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_REAL and op MPI_PROD'
	endif

       fnderr = .false.
       do 23012 i=1,count
	dblein(i) = i
        dblesol(i) = (i)**(size)
	dbleout(i) = 0
23012	continue
       call MPI_Allreduce( dblein, dbleout, count,
     *      MPI_DOUBLE_PRECISION, MPI_PROD, comm, ierr )
              do 23013 i=1,count
        if (dbleout(i).ne.dblesol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23013	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_DOUBLE_PRECISION and op MPI_PROD'
	endif

       fnderr = .false.
       do 23014 i=1,count
	cplxin(i) = i
        cplxsol(i) = (i)**(size)
	cplxout(i) = 0
23014	continue
       call MPI_Allreduce( cplxin, cplxout, count,
     *      MPI_COMPLEX, MPI_PROD, comm, ierr )
              do 23015 i=1,count
        if (cplxout(i).ne.cplxsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23015	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_COMPLEX and op MPI_PROD'
	endif

	if (errcnt .gt. 0) then
	print *, 'Found ', errcnt, ' errors on ', rank, ' for MPI_PROD'
	endif
	errcnt = 0

C  Test max
	if (world_rank .eq. 0) print *, ' MPI_MAX'

       fnderr = .false.
       do 23016 i=1,count
	intin(i) = (rank + i)
        intsol(i) = (size - 1 + i)
	intout(i) = 0
23016	continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_MAX, comm, ierr )
              do 23017 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23017	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_INTEGER and op MPI_MAX'
	endif

       fnderr = .false.
       do 23018 i=1,count
	realin(i) = (rank + i)
        realsol(i) = (size - 1 + i)
	realout(i) = 0
23018	continue
       call MPI_Allreduce( realin, realout, count,
     *      MPI_REAL, MPI_MAX, comm, ierr )
              do 23019 i=1,count
        if (realout(i).ne.realsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23019	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_REAL and op MPI_MAX'
	endif

       fnderr = .false.
       do 23020 i=1,count
	dblein(i) = (rank + i)
        dblesol(i) = (size - 1 + i)
	dbleout(i) = 0
23020	continue
       call MPI_Allreduce( dblein, dbleout, count,
     *      MPI_DOUBLE_PRECISION, MPI_MAX, comm, ierr )
              do 23021 i=1,count
        if (dbleout(i).ne.dblesol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23021	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_DOUBLE_PRECISION and op MPI_MAX'
	endif

	if (errcnt .gt. 0) then
	print *, 'Found ', errcnt, ' errors on ', rank, ' for MPI_MAX'
	endif
	errcnt = 0

C Test min
	if (world_rank .eq. 0) print *, ' MPI_MIN'

       fnderr = .false.
       do 23022 i=1,count
	intin(i) = (rank + i)
        intsol(i) = i
	intout(i) = 0
23022	continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_MIN, comm, ierr )
              do 23023 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23023	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_INTEGER and op MPI_MIN'
	endif

       fnderr = .false.
       do 23024 i=1,count
	realin(i) = (rank + i)
        realsol(i) = i
	realout(i) = 0
23024	continue
       call MPI_Allreduce( realin, realout, count,
     *      MPI_REAL, MPI_MIN, comm, ierr )
              do 23025 i=1,count
        if (realout(i).ne.realsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23025	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_REAL and op MPI_MIN'
	endif

       fnderr = .false.
       do 23026 i=1,count
	dblein(i) = (rank + i)
        dblesol(i) = i
	dbleout(i) = 0
23026	continue
       call MPI_Allreduce( dblein, dbleout, count,
     *      MPI_DOUBLE_PRECISION, MPI_MIN, comm, ierr )
              do 23027 i=1,count
        if (dbleout(i).ne.dblesol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23027	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_DOUBLE_PRECISION and op MPI_MIN'
	endif

	if (errcnt .gt. 0) then
	print *, 'Found ', errcnt, ' errors on ', rank, ' for MPI_MIN'
	endif
	errcnt = 0

C Test LOR
	if (world_rank .eq. 0) print *, ' MPI_LOR'

       fnderr = .false.
       do 23028 i=1,count
	login(i) = (mod(rank,2) .eq. 1)
        logsol(i) = (size .gt. 1)
	logout(i) = .FALSE.
23028	continue
       call MPI_Allreduce( login, logout, count,
     *      MPI_LOGICAL, MPI_LOR, comm, ierr )
              do 23029 i=1,count
        if (logout(i).neqv.logsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23029	continue
       	if (fnderr) then
      print *, 'Error for type MPI_LOGICAL and op MPI_LOR'
	endif

	if (errcnt .gt. 0) then
	   print *, 'Found ', errcnt, ' errors on ', rank,
     *  	' for MPI_LOR(0)'
	endif
	errcnt = 0

       fnderr = .false.
       do 23030 i=1,count
	login(i) = .false.
        logsol(i) = .false.
	logout(i) = .FALSE.
23030	continue
       call MPI_Allreduce( login, logout, count,
     *      MPI_LOGICAL, MPI_LOR, comm, ierr )
              do 23031 i=1,count
        if (logout(i).neqv.logsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23031	continue
       	if (fnderr) then
      print *, 'Error for type MPI_LOGICAL and op MPI_LOR'
	endif

	if (errcnt .gt. 0) then
	   print *, 'Found ', errcnt, ' errors on ', rank,
     *              ' for MPI_LOR(1)'
	endif
	errcnt = 0

C Test LXOR
	if (world_rank .eq. 0) print *, ' MPI_LXOR'

       fnderr = .false.
       do 23032 i=1,count
	login(i) = (rank .eq. 1)
        logsol(i) = (size .gt. 1)
	logout(i) = .FALSE.
23032	continue
       call MPI_Allreduce( login, logout, count,
     *      MPI_LOGICAL, MPI_LXOR, comm, ierr )
              do 23033 i=1,count
        if (logout(i).neqv.logsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23033	continue
       	if (fnderr) then
      print *, 'Error for type MPI_LOGICAL and op MPI_LXOR'
	endif

	if (errcnt .gt. 0) then
	print *, 'Found ',errcnt,' errors on ', rank, ' for MPI_LXOR'
	endif
	errcnt = 0

       fnderr = .false.
       do 23034 i=1,count
	login(i) = .false.
        logsol(i) = .false.
	logout(i) = .FALSE.
23034	continue
       call MPI_Allreduce( login, logout, count,
     *      MPI_LOGICAL, MPI_LXOR, comm, ierr )
              do 23035 i=1,count
        if (logout(i).neqv.logsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23035	continue
       	if (fnderr) then
      print *, 'Error for type MPI_LOGICAL and op MPI_LXOR'
	endif

	if (errcnt .gt. 0) then
	print *, 'Found ',errcnt,' errors on ',rank,' for MPI_LXOR(0)'
	endif
	errcnt = 0

       fnderr = .false.
       do 23036 i=1,count
	login(i) = .true.
        logsol(i) = mod(size,2) .ne. 0
	logout(i) = .FALSE.
23036	continue
       call MPI_Allreduce( login, logout, count,
     *      MPI_LOGICAL, MPI_LXOR, comm, ierr )
              do 23037 i=1,count
        if (logout(i).neqv.logsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23037	continue
       	if (fnderr) then
      print *, 'Error for type MPI_LOGICAL and op MPI_LXOR'
	endif

	if (errcnt .gt. 0) then
	print *, 'Found ',errcnt,' errors on ',rank,' for MPI_LXOR(1-0)'
	endif
	errcnt = 0

C Test LAND
	if (world_rank .eq. 0) print *, ' MPI_LAND'

       fnderr = .false.
       do 23038 i=1,count
	login(i) = (mod(rank,2) .eq. 1)
        logsol(i) = .false.
	logout(i) = .FALSE.
23038	continue
       call MPI_Allreduce( login, logout, count,
     *      MPI_LOGICAL, MPI_LAND, comm, ierr )
              do 23039 i=1,count
        if (logout(i).neqv.logsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23039	continue
       	if (fnderr) then
      print *, 'Error for type MPI_LOGICAL and op MPI_LAND'
	endif

	if (errcnt .gt. 0) then
	print *, 'Found ', errcnt, ' errors on ', rank, ' for MPI_LAND'
	endif
	errcnt = 0

       fnderr = .false.
       do 23040 i=1,count
	login(i) = .true.
        logsol(i) = .true.
	logout(i) = .FALSE.
23040	continue
       call MPI_Allreduce( login, logout, count,
     *      MPI_LOGICAL, MPI_LAND, comm, ierr )
              do 23041 i=1,count
        if (logout(i).neqv.logsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23041	continue
       	if (fnderr) then
      print *, 'Error for type MPI_LOGICAL and op MPI_LAND'
	endif

	if (errcnt .gt. 0) then
	print *, 'Found ',errcnt,' errors on ',rank,
     *      ' for MPI_LAND(true)'
	endif
	errcnt = 0

C Test BOR
	if (world_rank .eq. 0) print *, ' MPI_BOR'
        if (size .lt. 3) then

       fnderr = .false.
       do 23042 i=1,count
	intin(i) = mod(rank,4)
        intsol(i) = size - 1
	intout(i) = 0
23042	continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_BOR, comm, ierr )
              do 23043 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23043	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_INTEGER and op MPI_BOR'
	endif

	else

       fnderr = .false.
       do 23044 i=1,count
	intin(i) = mod(rank,4)
        intsol(i) = 3
	intout(i) = 0
23044	continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_BOR, comm, ierr )
              do 23045 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23045	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_INTEGER and op MPI_BOR'
	endif

	endif
	if (errcnt .gt. 0) then
	print *, 'Found ', errcnt, ' errors on ', rank,
     *      	 ' for MPI_BOR(1)'
	endif
	errcnt = 0

C Test BAND
	if (world_rank .eq. 0) print *, ' MPI_BAND'
C See bottom for function definitions

       fnderr = .false.
       do 23046 i=1,count
	intin(i) = ibxandval(rank,size,i)
        intsol(i) = i
	intout(i) = 0
23046	continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_BAND, comm, ierr )
              do 23047 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23047	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_INTEGER and op MPI_BAND'
	endif

	if (errcnt .gt. 0) then
	print *, 'Found ', errcnt, ' errors on ', rank,
     *		' for MPI_BAND(1)'
	endif
	errcnt = 0

       fnderr = .false.
       do 23048 i=1,count
	intin(i) = ibxandval1(rank,size,i)
        intsol(i) = 0
	intout(i) = 0
23048	continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_BAND, comm, ierr )
              do 23049 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23049	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_INTEGER and op MPI_BAND'
	endif

	if (errcnt .gt. 0) then
	print *, 'Found ', errcnt, ' errors on ', rank,
     *		' for MPI_BAND(0)'
	endif
	errcnt = 0

C Test BXOR
	if (world_rank .eq. 0) print *, ' MPI_BXOR'
C See below for function definitions

       fnderr = .false.
       do 23050 i=1,count
	intin(i) = ibxorval1(rank)
        intsol(i) = ibxorsol1(size)
	intout(i) = 0
23050	continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_BXOR, comm, ierr )
              do 23051 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23051	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_INTEGER and op MPI_BXOR'
	endif

	if (errcnt .gt. 0) then
	print *, 'Found ', errcnt, ' errors on ', rank,
     *		' for MPI_BXOR(1)'
	endif
	errcnt = 0

       fnderr = .false.
       do 23052 i=1,count
	intin(i) = 0
        intsol(i) = 0
	intout(i) = 0
23052	continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_BXOR, comm, ierr )
              do 23053 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23053	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_INTEGER and op MPI_BXOR'
	endif

	if (errcnt .gt. 0) then
	print *, 'Found ', errcnt, ' errors on ', rank,
     *		' for MPI_BXOR(0)'
	endif
	errcnt = 0

C Assumes -1 == all bits set

       fnderr = .false.
       do 23054 i=1,count
	intin(i) = (-1)
	if (mod(size,2) .eq. 0) then
            intsol(i) = 0
        else
            intsol(i) = -1
        endif
	intout(i) = 0
23054	continue
       call MPI_Allreduce( intin, intout, count,
     *      MPI_INTEGER, MPI_BXOR, comm, ierr )
              do 23055 i=1,count
        if (intout(i).ne.intsol(i)) then
            errcnt = errcnt + 1
            fnderr = .true.
        endif
23055	continue
       	if (fnderr) then
	  print *, 'Error for type MPI_INTEGER and op MPI_BXOR'
	endif

	if (errcnt .gt. 0) then
	print *, 'Found ', errcnt, ' errors on ', rank,
     *		' for MPI_BXOR(1-0)'
	endif
	errcnt = 0

C Test Maxloc
	if (world_rank .eq. 0) print *, ' MPI_MAXLOC'

	fnderr = .false.
	do 23056 i=1, count
	   intin(2*i-1) = (rank + i)
	   intin(2*i)   = rank
	   intsol(2*i-1) = (size - 1 + i)
	   intsol(2*i) = (size-1)
	   intout(2*i-1) = 0
	   intout(2*i)   = 0
23056	continue
         	call MPI_Allreduce( intin, intout, count,
     *      MPI_2INTEGER, MPI_MAXLOC, comm, ierr )
	do 23057 i=1, count
	if (intout(2*i-1) .ne. intsol(2*i-1) .or.
     *      intout(2*i) .ne. intsol(2*i)) then
	    errcnt = errcnt + 1
	    fnderr = .true.
	endif
23057	continue
       	if (fnderr) then
	print *, 'Error for type MPI_2INTEGER and op MPI_MAXLOC'
	endif

	fnderr = .false.
	do 23058 i=1, count
	   realin(2*i-1) = (rank + i)
	   realin(2*i)   = rank
	   realsol(2*i-1) = (size - 1 + i)
	   realsol(2*i) = (size-1)
	   realout(2*i-1) = 0
	   realout(2*i)   = 0
23058	continue
         	call MPI_Allreduce( realin, realout, count,
     *      MPI_2REAL, MPI_MAXLOC, comm, ierr )
	do 23059 i=1, count
	if (realout(2*i-1) .ne. realsol(2*i-1) .or.
     *      realout(2*i) .ne. realsol(2*i)) then
	    errcnt = errcnt + 1
	    fnderr = .true.
	endif
23059	continue
       	if (fnderr) then
	print *, 'Error for type MPI_2REAL and op MPI_MAXLOC'
	endif

	fnderr = .false.
	do 23060 i=1, count
	   dblein(2*i-1) = (rank + i)
	   dblein(2*i)   = rank
	   dblesol(2*i-1) = (size - 1 + i)
	   dblesol(2*i) = (size-1)
	   dbleout(2*i-1) = 0
	   dbleout(2*i)   = 0
23060	continue
         	call MPI_Allreduce( dblein, dbleout, count,
     *      MPI_2DOUBLE_PRECISION, MPI_MAXLOC, comm, ierr )
	do 23061 i=1, count
	if (dbleout(2*i-1) .ne. dblesol(2*i-1) .or.
     *      dbleout(2*i) .ne. dblesol(2*i)) then
	    errcnt = errcnt + 1
	    fnderr = .true.
	endif
23061	continue
       	if (fnderr) then
	   print *,
     *     'Error for type MPI_2DOUBLE_PRECISION and op MPI_MAXLOC'

	endif

	if (errcnt .gt. 0) then
	print *, 'Found ', errcnt, ' errors on ', rank,
     *		' for MPI_MAXLOC'
	endif
	errcnt = 0

C Test minloc
	if (world_rank .eq. 0) print *, ' MPI_MINLOC'

	fnderr = .false.
	do 23062 i=1, count
	   intin(2*i-1) = (rank + i)
	   intin(2*i)   = rank
	   intsol(2*i-1) = i
	   intsol(2*i) = 0
	   intout(2*i-1) = 0
	   intout(2*i)   = 0
23062	continue
         	call MPI_Allreduce( intin, intout, count,
     *      MPI_2INTEGER, MPI_MINLOC, comm, ierr )
	do 23063 i=1, count
	if (intout(2*i-1) .ne. intsol(2*i-1) .or.
     *      intout(2*i) .ne. intsol(2*i)) then
	    errcnt = errcnt + 1
	    fnderr = .true.
	endif
23063	continue
       	if (fnderr) then
	print *, 'Error for type MPI_2INTEGER and op MPI_MINLOC'
	endif

	fnderr = .false.
	do 23064 i=1, count
	   realin(2*i-1) = (rank + i)
	   realin(2*i)   = rank
	   realsol(2*i-1) = i
	   realsol(2*i) = 0
	   realout(2*i-1) = 0
	   realout(2*i)   = 0
23064	continue
         	call MPI_Allreduce( realin, realout, count,
     *      MPI_2REAL, MPI_MINLOC, comm, ierr )
	do 23065 i=1, count
	if (realout(2*i-1) .ne. realsol(2*i-1) .or.
     *      realout(2*i) .ne. realsol(2*i)) then
	    errcnt = errcnt + 1
	    fnderr = .true.
	endif
23065	continue
       	if (fnderr) then
	print *, 'Error for type MPI_2REAL and op MPI_MINLOC'
	endif

	fnderr = .false.
	do 23066 i=1, count
	   dblein(2*i-1) = (rank + i)
	   dblein(2*i)   = rank
	   dblesol(2*i-1) = i
	   dblesol(2*i) = 0
	   dbleout(2*i-1) = 0
	   dbleout(2*i)   = 0
23066	continue
         	call MPI_Allreduce( dblein, dbleout, count,
     *      MPI_2DOUBLE_PRECISION, MPI_MINLOC, comm, ierr )
	do 23067 i=1, count
	if (dbleout(2*i-1) .ne. dblesol(2*i-1) .or.
     *      dbleout(2*i) .ne. dblesol(2*i)) then
	    errcnt = errcnt + 1
	    fnderr = .true.
	endif
23067	continue
       	if (fnderr) then
	   print *,
     *      'Error for type MPI_2DOUBLE_PRECISION and op MPI_MINLOC'
	endif

	if (errcnt .gt. 0) then
	print *, 'Found ', errcnt, ' errors on ', rank,
     *		' for MPI_MINLOC'
	endif
	errcnt = 0

	call MPI_Finalize( ierr )
	end

	integer function ibxorval1( ir )
	ibxorval1 = 0
	if (ir .eq. 1) ibxorval1 = 16+32+64+128
	return
	end

	integer function ibxorsol1( is )
	ibxorsol1 = 0
	if (is .gt. 1) ibxorsol1 = 16+32+64+128
	return
	end

C
C	Assumes -1 == all bits set
	integer function ibxandval( ir, is, i )
	integer ir, is, i
	ibxandval = -1
	if (ir .eq. is - 1) ibxandval = i
	return
	end
C
	integer function ibxandval1( ir, is, i )
	integer ir, is, i
	ibxandval1 = 0
	if (ir .eq. is - 1) ibxandval1 = i
	return
	end


C     Bug (?): the index  I for loop 12 was not constrained by the loop bounds because
C     of the symbolic increment. This was changed because the precondition implies that
C     ISTEP is positive here.

*****|******************************************************************|
      SUBROUTINE FOUR5(DATA,N,IX)
*****|******************************************************************|
*     Replaces DATA by its discrete Fourier transform
*     IX      : >0 Fourier Analysis
*               <0 Fourier Synthesis
*     DATA    : Complex array of length N.
*               N must be an integer power of 2 (non verifie)
*-----------------------------------------------------------------------|
      INTEGER  N,IX
      REAL DATA(2*N)
*
      INTEGER  I,J,IXX,NN,M,MMAX,ISTEP
      REAL     TEMPI,TEMPR
      DOUBLE PRECISION WR,WI,WPR,WPI,WTEMP,THETA
*-----------------------------------------------------------------------|
      IXX=ISIGN(1,IX)
      NN=2*N
*
*     Bit reversal
*     ------------
      J=1
      DO 11 I=1,NN,2
        IF(J.GT.I)THEN
          TEMPR=DATA(J)
          TEMPI=DATA(J+1)
          DATA(J)=DATA(I)
          DATA(J+1)=DATA(I+1)
          DATA(I)=TEMPR
          DATA(I+1)=TEMPI
        ENDIF
        M=NN/2
1       IF ((M.GE.2).AND.(J.GT.M)) THEN
          J=J-M
          M=M/2
        GO TO 1
        ENDIF
        J=J+M
11    CONTINUE
*
*     Danielson-Lanczos algorithm
*     ---------------------------
      MMAX=2
2     IF (NN.GT.MMAX) THEN
         IF (NN.GT.MMAX.AND.MMAX.GE.2) THEN
        ISTEP=2*MMAX
        THETA=6.28318530717959D0/(IXX*MMAX)
        WPR=-2.D0*DSIN(0.5D0*THETA)**2
        WPI=DSIN(THETA)
        WR=1.D0
        WI=0.D0
        DO 13 M=1,MMAX,2
          DO 12 I=M,NN,ISTEP
            J=I+MMAX
            TEMPR=SNGL(WR)*DATA(J)-SNGL(WI)*DATA(J+1)
            TEMPI=SNGL(WR)*DATA(J+1)+SNGL(WI)*DATA(J)
            DATA(J)=DATA(I)-TEMPR
            DATA(J+1)=DATA(I+1)-TEMPI
            DATA(I)=DATA(I)+TEMPR
            DATA(I+1)=DATA(I+1)+TEMPI
12        CONTINUE
          WTEMP=WR
          WR=WR*WPR-WI*WPI+WR
          WI=WI*WPR+WTEMP*WPI+WI
13      CONTINUE
        MMAX=ISTEP
        endif
      GO TO 2
      ENDIF
*
      END


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   cusp.f90 - cusp normal form
!----------------------------------------------------------------------
!----------------------------------------------------------------------

SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!--------- ----

! Evaluates the algebraic equations or ODE right hand side

! Input arguments :
!      NDIM   :   Dimension of the algebraic or ODE system
!      U      :   State variables
!      ICP    :   Array indicating the free parameter(s)
!      PAR    :   Equation parameters

! Values to be returned :
!      F      :   Equation or ODE right hand side values

! Normally unused Jacobian arguments : IJAC, DFDU, DFDP (see manual)

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM, IJAC, ICP(*)
  DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
  DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
  DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM),DFDP(NDIM,*)

  DOUBLE PRECISION x, mu, lambda

  x = U(1)
  lambda = PAR(1)
  mu = PAR(2)
  F(1)= mu + lambda*x - x**3

END SUBROUTINE FUNC

!-----------------------------------------------------------------------
!-----------------------------------------------------------------------

SUBROUTINE STPNT(NDIM,U,PAR,T)
!--------- -----

! Input arguments :
!      NDIM   :   Dimension of the algebraic or ODE system

! Values to be returned :
!      U      :   A starting solution vector
!      PAR    :   The corresponding equation-parameter values

! Note : For time- or space-dependent solutions this subroutine has
!        the scalar input parameter T contains the varying time or space
!        variable value.

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM
  DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
  DOUBLE PRECISION, INTENT(IN) :: T

! Initialize the equation parameters
  PAR(1:2) = (/ 1.0d0, 0.0d0 /)

! Initialize the solution
  U(1) = 0.0d0

END SUBROUTINE STPNT

!----------------------------------------------------------------------
!----------------------------------------------------------------------

SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
!--------- ----

! Boundary Conditions

! Input arguments :
!      NDIM   :   Dimension of the ODE system
!      PAR    :   Equation parameters
!      ICP    :   Array indicating the free parameter(s)
!      NBC    :   Number of boundary conditions
!      U0     :   State variable values at the left boundary
!      U1     :   State variable values at the right boundary

! Values to be returned :
!      FB     :   The values of the boundary condition functions

! Normally unused Jacobian arguments : IJAC, DBC (see manual)

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
  DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
  DOUBLE PRECISION, INTENT(OUT) :: FB(NBC)
  DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)

!X FB(1)=
!X FB(2)=

END SUBROUTINE BCND

!----------------------------------------------------------------------
!----------------------------------------------------------------------

SUBROUTINE ICND(NDIM,PAR,ICP,NINT,U,UOLD,UDOT,UPOLD,FI,IJAC,DINT)
!--------- ----

! Integral Conditions

! Input arguments :
!      NDIM   :   Dimension of the ODE system
!      PAR    :   Equation parameters
!      ICP    :   Array indicating the free parameter(s)
!      NINT   :   Number of integral conditions
!      U      :   Value of the vector function U at `time' t

! The following input arguments, which are normally not needed,
! correspond to the preceding point on the solution branch
!      UOLD   :   The state vector at 'time' t
!      UDOT   :   Derivative of UOLD with respect to arclength
!      UPOLD  :   Derivative of UOLD with respect to `time'

! Normally unused Jacobian arguments : IJAC, DINT

! Values to be returned :
!      FI     :   The value of the vector integrand

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM, ICP(*), NINT, IJAC
  DOUBLE PRECISION, INTENT(IN) :: PAR(*)
  DOUBLE PRECISION, INTENT(IN) :: U(NDIM), UOLD(NDIM), UDOT(NDIM), UPOLD(NDIM)
  DOUBLE PRECISION, INTENT(OUT) :: FI(NINT)
  DOUBLE PRECISION, INTENT(INOUT) :: DINT(NINT,*)

!X FI(1)=

END SUBROUTINE ICND

!----------------------------------------------------------------------
!----------------------------------------------------------------------

SUBROUTINE FOPT(NDIM,U,ICP,PAR,IJAC,FS,DFDU,DFDP)
!--------- ----
!
! Defines the objective function for algebraic optimization problems
!
! Supplied variables :
!      NDIM   :   Dimension of the state equation
!      U      :   The state vector
!      ICP    :   Indices of the control parameters
!      PAR    :   The vector of control parameters
!
! Values to be returned :
!      FS      :   The value of the objective function
!
! Normally unused Jacobian argument : IJAC, DFDP

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
  DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
  DOUBLE PRECISION, INTENT(OUT) :: FS
  DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM),DFDP(*)

!X FS=

END SUBROUTINE FOPT

!----------------------------------------------------------------------
!----------------------------------------------------------------------

SUBROUTINE PVLS(NDIM,U,PAR)
!--------- ----

  IMPLICIT NONE
  INTEGER, INTENT(IN) :: NDIM
  DOUBLE PRECISION, INTENT(IN) :: U(NDIM)
  DOUBLE PRECISION, INTENT(INOUT) :: PAR(*)

!----------------------------------------------------------------------
! NOTE :
! Parameters set in this subroutine should be considered as ``solution
! measures'' and be used for output purposes only.
!
! They should never be used as `true'' continuation parameters.
!
! They may, however, be added as ``over-specified parameters'' in the
! parameter list associated with the AUTO-Constant NICP, in order to
! print their values on the screen and in the ``p.xxx file.
!
! They may also appear in the list associated with AUTO-Constant NUZR.
!
!----------------------------------------------------------------------
! For algebraic problems the argument U is, as usual, the state vector.
! For differential equations the argument U represents the approximate
! solution on the entire interval [0,1]. In this case its values must
! be accessed indirectly by calls to GETP, as illustrated below.
!----------------------------------------------------------------------
!
! Set PAR(2) equal to the L2-norm of U(1)
!X PAR(2)=GETP('NRM',1,U)
!
! Set PAR(3) equal to the minimum of U(2)
!X PAR(3)=GETP('MIN',2,U)
!
! Set PAR(4) equal to the value of U(2) at the left boundary.
!X PAR(4)=GETP('BV0',2,U)
!
! Set PAR(5) equal to the pseudo-arclength step size used.
!X PAR(5)=GETP('STP',1,U)
!
!----------------------------------------------------------------------
! The first argument of GETP may be one of the following:
!        'NRM' (L2-norm),     'MAX' (maximum),
!        'INT' (integral),    'BV0 (left boundary value),
!        'MIN' (minimum),     'BV1' (right boundary value).
!
! Also available are
!   'STP' (Pseudo-arclength step size used).
!   'FLD' (`Fold function', which vanishes at folds).
!   'BIF' (`Bifurcation function', which vanishes at singular points).
!   'HBF' (`Hopf function'; which vanishes at Hopf points).
!   'SPB' ( Function which vanishes at secondary periodic bifurcations).
!----------------------------------------------------------------------

END SUBROUTINE PVLS

!----------------------------------------------------------------------
!----------------------------------------------------------------------


subroutine mydotf32(n,x,jx,y,jy,z)
    use ISO_FORTRAN_ENV
    implicit none
    integer, intent(in) :: n,jx,jy
    integer :: i
    real(kind=REAL32), intent(in) :: x(n),y(n)
    real(kind=REAL32), intent(out) :: z
    real(kind=REAL32) :: r
    if ((jx.ne.1).or.(jy.ne.1)) then
        print*,'mydotf32 supports stride 1 only'
        call abort
    endif
    r = 0.0
    do i=1,n
        r = r + x(i) * y(i)
    enddo
    z = r
    return
end subroutine mydotf32

subroutine mydotf64(n,x,jx,y,jy,z)
    use ISO_FORTRAN_ENV
    implicit none
    integer, intent(in) :: n,jx,jy
    integer :: i
    real(kind=REAL64), intent(in) :: x(n),y(n)
    real(kind=REAL64), intent(out) :: z
    real(kind=REAL64) :: r
    if ((jx.ne.1).or.(jy.ne.1)) then
        print*,'mydotf64 supports stride 1 only'
        call abort
    endif
    r = 0.0
    do i=1,n
        r = r + x(i) * y(i)
    enddo
    z = r
    return
end subroutine mydotf64

subroutine mydotf128(n,x,jx,y,jy,z)
    use ISO_FORTRAN_ENV
    implicit none
    integer, intent(in) :: n,jx,jy
    integer :: i
    real(kind=REAL128), intent(in) :: x(n),y(n)
    real(kind=REAL128), intent(out) :: z
    real(kind=REAL128) :: r
    if ((jx.ne.1).or.(jy.ne.1)) then
        print*,'mydotf128 supports stride 1 only'
        call abort
    endif
    r = 0.0
    do i=1,n
        r = r + x(i) * y(i)
    enddo
    z = r
    return
end subroutine mydotf128

subroutine mydotof128if64(n,x,jx,y,jy,z)
    use ISO_FORTRAN_ENV
    implicit none
    integer, intent(in) :: n,jx,jy
    integer :: i
    real(kind=REAL64), intent(in) :: x(n),y(n)
    real(kind=REAL128), intent(out) :: z
    real(kind=REAL128) :: r,tx,ty
    if ((jx.ne.1).or.(jy.ne.1)) then
        print*,'mydotf128 supports stride 1 only'
        call abort
    endif
    r = 0.0
    do i=1,n
        tx = x(i)
        ty = y(i)
        r = r + tx * ty
    enddo
    z = r
    return
end subroutine mydotof128if64


module Mod_nsc_bouwal
contains
subroutine nsc_bouwal(e,gpvel,visac,denac,delta,tract)

!-----------------------------------------------------------------------
!****f* Nscomp/nsc_bouwal
! NAME
!    nsm_bouwal
! DESCRIPTION
!    This routine computes the surface traction for the NS equations at
!    a given integration point of a boundary IBOUN received by argument
!    due to the use of a turbulent wall law. The algorithm is:
!    - Compute the tangential velocity u at the integration point x.
!      In fact, u is not necessarily tangential at x. For example:
!      -> u    -> u
!      o---x---o---x---o
!                      |\ u
!                      |
!    - Given the distance to the wall y, compute (U*) (friction velocity)
!    - Compute y+=(y)(U*)/(nu)
!      if(y+>5) then
!        t=-(rho)*(U*)^2*(u/|u|)
!      else
!        u+=y+ => U*^2=u*nu/y so that
!        t=-mu*u/y
!      end if
! USES
!    vecnor
!    frivel
! USED BY
!    nsc_bouope
!***
!-----------------------------------------------------------------------
   use typre
   use Mod_Element
   implicit none
   class(FiniteElement) :: e
   real(rp) :: gpvel(e%ndime),visac,denac,delta
   real(rp) :: tract(e%ndime+2)

   real(rp),parameter         :: zensi = epsilon(1.0_rp)

   integer(ip)                :: ldime,idime,ldimb

   real(rp)                   :: vikin,velfr,yplus    ! nu, U*, y+, y
   real(rp)                   :: tveno,tvelo(e%ndime),ovelo(e%ndime)             ! |u|, u

   if(delta<zensi) return

   !normal velocity, projection of a over b: a_b = (a . b) b
   ovelo = dot_product(e%baloc(:,e%ndime),gpvel)*e%baloc(:,e%ndime)

   tvelo = gpvel - ovelo
   call vecnor(tvelo,e%ndime,tveno,2)                       ! |u|
   vikin=visac/denac                                      ! nu
   if(tveno<=zensi) then
      velfr=0.0_rp
      tract=0.0_rp
      return
   else
      call frivel(delta,tveno,vikin,velfr)                  ! U*
   end if

   ! Compute prescribed traction

   yplus=delta*velfr/vikin
   if(yplus<5.0_rp) then
      tract(2:e%ndime+1) = -denac*vikin*tvelo/delta                  ! t=-mu*u/y
   else
      tract(2:e%ndime+1) = -denac*velfr*velfr*tvelo/tveno            ! t=-rho*U*^2*(u/|u|)
   end if

end subroutine nsc_bouwal
end module


! CKE budget stuff

subroutine stat_tke(du,tkele)

use vars
implicit none
real du(nx,ny,nz,3)
real tkele(nzm)
real d_u(nz), d_v(nz),d_w(nz),coef
integer i,j,k
coef = 1./float(nx*ny)
do k=1,nz
 d_u(k)=0.
 d_v(k)=0.
 d_w(k)=0.
end do
do k=1,nzm
 do j=1,ny
  do i=1,nx
   d_u(k)=d_u(k)+(u(i,j,k)-u0(k))*du(i,j,k,1)
   d_v(k)=d_v(k)+(v(i,j,k)-v0(k))*du(i,j,k,2)
   d_w(k)=d_w(k)+ w(i,j,k) *      du(i,j,k,3)
  end do
 end do
 d_u(k)=d_u(k)*coef
 d_v(k)=d_v(k)*coef
 d_w(k)=d_w(k)*coef
end do
do k=1,nzm
 tkele(k)=0.5*(d_w(k)+d_w(k+1))+d_u(k)+d_v(k)*YES3D
end do

end