      subroutine concur(iopt,idim,m,u,mx,x,xx,w,ib,db,nb,ie,de,ne,k,s,
     * nest,n,t,nc,c,np,cp,fp,wrk,lwrk,iwrk,ier)
c  given the ordered set of m points x(i) in the idim-dimensional space
c  and given also a corresponding set of strictly increasing values u(i)
c  and the set of positive numbers w(i),i=1,2,...,m, subroutine concur
c  determines a smooth approximating spline curve s(u), i.e.
c      x1 = s1(u)
c      x2 = s2(u)      ub = u(1) <= u <= u(m) = ue
c      .........
c      xidim = sidim(u)
c  with sj(u),j=1,2,...,idim spline functions of odd degree k with
c  common knots t(j),j=1,2,...,n.
c  in addition these splines will satisfy the following boundary
c  constraints        (l)
c      if ib > 0 :  sj   (u(1)) = db(idim*l+j) ,l=0,1,...,ib-1
c  and                (l)
c      if ie > 0 :  sj   (u(m)) = de(idim*l+j) ,l=0,1,...,ie-1.
c  if iopt=-1 concur calculates the weighted least-squares spline curve
c  according to a given set of knots.
c  if iopt>=0 the number of knots of the splines sj(u) and the position
c  t(j),j=1,2,...,n is chosen automatically by the routine. the smooth-
c  ness of s(u) is then achieved by minimalizing the discontinuity
c  jumps of the k-th derivative of s(u) at the knots t(j),j=k+2,k+3,...,
c  n-k-1. the amount of smoothness is determined by the condition that
c  f(p)=sum((w(i)*dist(x(i),s(u(i))))**2) be <= s, with s a given non-
c  negative constant, called the smoothing factor.
c  the fit s(u) is given in the b-spline representation and can be
c  evaluated by means of subroutine curev.
c
c  calling sequence:
c     call concur(iopt,idim,m,u,mx,x,xx,w,ib,db,nb,ie,de,ne,k,s,nest,n,
c    * t,nc,c,np,cp,fp,wrk,lwrk,iwrk,ier)
c
c  parameters:
c   iopt  : integer flag. on entry iopt must specify whether a weighted
c           least-squares spline curve (iopt=-1) or a smoothing spline
c           curve (iopt=0 or 1) must be determined.if iopt=0 the routine
c           will start with an initial set of knots t(i)=ub,t(i+k+1)=ue,
c           i=1,2,...,k+1. if iopt=1 the routine will continue with the
c           knots found at the last call of the routine.
c           attention: a call with iopt=1 must always be immediately
c           preceded by another call with iopt=1 or iopt=0.
c           unchanged on exit.
c   idim  : integer. on entry idim must specify the dimension of the
c           curve. 0 < idim < 11.
c           unchanged on exit.
c   m     : integer. on entry m must specify the number of data points.
c           m > k-max(ib-1,0)-max(ie-1,0). unchanged on exit.
c   u     : real array of dimension at least (m). before entry,
c           u(i) must be set to the i-th value of the parameter variable
c           u for i=1,2,...,m. these values must be supplied in
c           strictly ascending order and will be unchanged on exit.
c   mx    : integer. on entry mx must specify the actual dimension of
c           the arrays x and xx as declared in the calling (sub)program
c           mx must not be too small (see x). unchanged on exit.
c   x     : real array of dimension at least idim*m.
c           before entry, x(idim*(i-1)+j) must contain the j-th coord-
c           inate of the i-th data point for i=1,2,...,m and j=1,2,...,
c           idim. unchanged on exit.
c   xx    : real array of dimension at least idim*m.
c           used as working space. on exit xx contains the coordinates
c           of the data points to which a spline curve with zero deriv-
c           ative constraints has been determined.
c           if the computation mode iopt =1 is used xx should be left
c           unchanged between calls.
c   w     : real array of dimension at least (m). before entry, w(i)
c           must be set to the i-th value in the set of weights. the
c           w(i) must be strictly positive. unchanged on exit.
c           see also further comments.
c   ib    : integer. on entry ib must specify the number of derivative
c           constraints for the curve at the begin point. 0<=ib<=(k+1)/2
c           unchanged on exit.
c   db    : real array of dimension nb. before entry db(idim*l+j) must
c           contain the l-th order derivative of sj(u) at u=u(1) for
c           j=1,2,...,idim and l=0,1,...,ib-1 (if ib>0).
c           unchanged on exit.
c   nb    : integer, specifying the dimension of db. nb>=max(1,idim*ib)
c           unchanged on exit.
c   ie    : integer. on entry ie must specify the number of derivative
c           constraints for the curve at the end point. 0<=ie<=(k+1)/2
c           unchanged on exit.
c   de    : real array of dimension ne. before entry de(idim*l+j) must
c           contain the l-th order derivative of sj(u) at u=u(m) for
c           j=1,2,...,idim and l=0,1,...,ie-1 (if ie>0).
c           unchanged on exit.
c   ne    : integer, specifying the dimension of de. ne>=max(1,idim*ie)
c           unchanged on exit.
c   k     : integer. on entry k must specify the degree of the splines.
c           k=1,3 or 5.
c           unchanged on exit.
c   s     : real.on entry (in case iopt>=0) s must specify the smoothing
c           factor. s >=0. unchanged on exit.
c           for advice on the choice of s see further comments.
c   nest  : integer. on entry nest must contain an over-estimate of the
c           total number of knots of the splines returned, to indicate
c           the storage space available to the routine. nest >=2*k+2.
c           in most practical situation nest=m/2 will be sufficient.
c           always large enough is nest=m+k+1+max(0,ib-1)+max(0,ie-1),
c           the number of knots needed for interpolation (s=0).
c           unchanged on exit.
c   n     : integer.
c           unless ier = 10 (in case iopt >=0), n will contain the
c           total number of knots of the smoothing spline curve returned
c           if the computation mode iopt=1 is used this value of n
c           should be left unchanged between subsequent calls.
c           in case iopt=-1, the value of n must be specified on entry.
c   t     : real array of dimension at least (nest).
c           on succesful exit, this array will contain the knots of the
c           spline curve,i.e. the position of the interior knots t(k+2),
c           t(k+3),..,t(n-k-1) as well as the position of the additional
c           t(1)=t(2)=...=t(k+1)=ub and t(n-k)=...=t(n)=ue needed for
c           the b-spline representation.
c           if the computation mode iopt=1 is used, the values of t(1),
c           t(2),...,t(n) should be left unchanged between subsequent
c           calls. if the computation mode iopt=-1 is used, the values
c           t(k+2),...,t(n-k-1) must be supplied by the user, before
c           entry. see also the restrictions (ier=10).
c   nc    : integer. on entry nc must specify the actual dimension of
c           the array c as declared in the calling (sub)program. nc
c           must not be too small (see c). unchanged on exit.
c   c     : real array of dimension at least (nest*idim).
c           on succesful exit, this array will contain the coefficients
c           in the b-spline representation of the spline curve s(u),i.e.
c           the b-spline coefficients of the spline sj(u) will be given
c           in c(n*(j-1)+i),i=1,2,...,n-k-1 for j=1,2,...,idim.
c   cp    : real array of dimension at least 2*(k+1)*idim.
c           on exit cp will contain the b-spline coefficients of a
c           polynomial curve which satisfies the boundary constraints.
c           if the computation mode iopt =1 is used cp should be left
c           unchanged between calls.
c   np    : integer. on entry np must specify the actual dimension of
c           the array cp as declared in the calling (sub)program. np
c           must not be too small (see cp). unchanged on exit.
c   fp    : real. unless ier = 10, fp contains the weighted sum of
c           squared residuals of the spline curve returned.
c   wrk   : real array of dimension at least m*(k+1)+nest*(6+idim+3*k).
c           used as working space. if the computation mode iopt=1 is
c           used, the values wrk(1),...,wrk(n) should be left unchanged
c           between subsequent calls.
c   lwrk  : integer. on entry,lwrk must specify the actual dimension of
c           the array wrk as declared in the calling (sub)program. lwrk
c           must not be too small (see wrk). unchanged on exit.
c   iwrk  : integer array of dimension at least (nest).
c           used as working space. if the computation mode iopt=1 is
c           used,the values iwrk(1),...,iwrk(n) should be left unchanged
c           between subsequent calls.
c   ier   : integer. unless the routine detects an error, ier contains a
c           non-positive value on exit, i.e.
c    ier=0  : normal return. the curve returned has a residual sum of
c             squares fp such that abs(fp-s)/s <= tol with tol a relat-
c             ive tolerance set to 0.001 by the program.
c    ier=-1 : normal return. the curve returned is an interpolating
c             spline curve, satisfying the constraints (fp=0).
c    ier=-2 : normal return. the curve returned is the weighted least-
c             squares polynomial curve of degree k, satisfying the
c             constraints. in this extreme case fp gives the upper
c             bound fp0 for the smoothing factor s.
c    ier=1  : error. the required storage space exceeds the available
c             storage space, as specified by the parameter nest.
c             probably causes : nest too small. if nest is already
c             large (say nest > m/2), it may also indicate that s is
c             too small
c             the approximation returned is the least-squares spline
c             curve according to the knots t(1),t(2),...,t(n). (n=nest)
c             the parameter fp gives the corresponding weighted sum of
c             squared residuals (fp>s).
c    ier=2  : error. a theoretically impossible result was found during
c             the iteration proces for finding a smoothing spline curve
c             with fp = s. probably causes : s too small.
c             there is an approximation returned but the corresponding
c             weighted sum of squared residuals does not satisfy the
c             condition abs(fp-s)/s < tol.
c    ier=3  : error. the maximal number of iterations maxit (set to 20
c             by the program) allowed for finding a smoothing curve
c             with fp=s has been reached. probably causes : s too small
c             there is an approximation returned but the corresponding
c             weighted sum of squared residuals does not satisfy the
c             condition abs(fp-s)/s < tol.
c    ier=10 : error. on entry, the input data are controlled on validity
c             the following restrictions must be satisfied.
c             -1<=iopt<=1, k = 1,3 or 5, m>k-max(0,ib-1)-max(0,ie-1),
c             nest>=2k+2, 0<idim<=10, lwrk>=(k+1)*m+nest*(6+idim+3*k),
c             nc >=nest*idim ,u(1)<u(2)<...<u(m),w(i)>0 i=1,2,...,m,
c             mx>=idim*m,0<=ib<=(k+1)/2,0<=ie<=(k+1)/2,nb>=1,ne>=1,
c             nb>=ib*idim,ne>=ib*idim,np>=2*(k+1)*idim,
c             if iopt=-1:2*k+2<=n<=min(nest,mmax) with mmax = m+k+1+
c                        max(0,ib-1)+max(0,ie-1)
c                        u(1)<t(k+2)<t(k+3)<...<t(n-k-1)<u(m)
c                       the schoenberg-whitney conditions, i.e. there
c                       must be a subset of data points uu(j) such that
c                         t(j) < uu(j) < t(j+k+1), j=1+max(0,ib-1),...
c                                                   ,n+k-1-max(0,ie-1)
c             if iopt>=0: s>=0
c                         if s=0 : nest >=mmax (see above)
c             if one of these conditions is found to be violated,control
c             is immediately repassed to the calling program. in that
c             case there is no approximation returned.
c
c  further comments:
c   by means of the parameter s, the user can control the tradeoff
c   between closeness of fit and smoothness of fit of the approximation.
c   if s is too large, the curve will be too smooth and signal will be
c   lost ; if s is too small the curve will pick up too much noise. in
c   the extreme cases the program will return an interpolating curve if
c   s=0 and the least-squares polynomial curve of degree k if s is
c   very large. between these extremes, a properly chosen s will result
c   in a good compromise between closeness of fit and smoothness of fit.
c   to decide whether an approximation, corresponding to a certain s is
c   satisfactory the user is highly recommended to inspect the fits
c   graphically.
c   recommended values for s depend on the weights w(i). if these are
c   taken as 1/d(i) with d(i) an estimate of the standard deviation of
c   x(i), a good s-value should be found in the range (m-sqrt(2*m),m+
c   sqrt(2*m)). if nothing is known about the statistical error in x(i)
c   each w(i) can be set equal to one and s determined by trial and
c   error, taking account of the comments above. the best is then to
c   start with a very large value of s ( to determine the least-squares
c   polynomial curve and the upper bound fp0 for s) and then to
c   progressively decrease the value of s ( say by a factor 10 in the
c   beginning, i.e. s=fp0/10, fp0/100,...and more carefully as the
c   approximating curve shows more detail) to obtain closer fits.
c   to economize the search for a good s-value the program provides with
c   different modes of computation. at the first call of the routine, or
c   whenever he wants to restart with the initial set of knots the user
c   must set iopt=0.
c   if iopt=1 the program will continue with the set of knots found at
c   the last call of the routine. this will save a lot of computation
c   time if concur is called repeatedly for different values of s.
c   the number of knots of the spline returned and their location will
c   depend on the value of s and on the complexity of the shape of the
c   curve underlying the data. but, if the computation mode iopt=1 is
c   used, the knots returned may also depend on the s-values at previous
c   calls (if these were smaller). therefore, if after a number of
c   trials with different s-values and iopt=1, the user can finally
c   accept a fit as satisfactory, it may be worthwhile for him to call
c   concur once more with the selected value for s but now with iopt=0.
c   indeed, concur may then return an approximation of the same quality
c   of fit but with fewer knots and therefore better if data reduction
c   is also an important objective for the user.
c
c   the form of the approximating curve can strongly be affected by
c   the choice of the parameter values u(i). if there is no physical
c   reason for choosing a particular parameter u, often good results
c   will be obtained with the choice
c        v(1)=0, v(i)=v(i-1)+q(i), i=2,...,m, u(i)=v(i)/v(m), i=1,..,m
c   where
c        q(i)= sqrt(sum j=1,idim (xj(i)-xj(i-1))**2 )
c   other possibilities for q(i) are
c        q(i)= sum j=1,idim (xj(i)-xj(i-1))**2
c        q(i)= sum j=1,idim abs(xj(i)-xj(i-1))
c        q(i)= max j=1,idim abs(xj(i)-xj(i-1))
c        q(i)= 1
c
c  other subroutines required:
c    fpback,fpbspl,fpched,fpcons,fpdisc,fpgivs,fpknot,fprati,fprota
c    curev,fppocu,fpadpo,fpinst
c
c  references:
c   dierckx p. : algorithms for smoothing data with periodic and
c                parametric splines, computer graphics and image
c                processing 20 (1982) 171-184.
c   dierckx p. : algorithms for smoothing data with periodic and param-
c                etric splines, report tw55, dept. computer science,
c                k.u.leuven, 1981.
c   dierckx p. : curve and surface fitting with splines, monographs on
c                numerical analysis, oxford university press, 1993.
c
c  author:
c    p.dierckx
c    dept. computer science, k.u. leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  creation date : may 1979
c  latest update : march 1987
c
c  ..
c  ..scalar arguments..
      real*8 s,fp
      integer iopt,idim,m,mx,ib,nb,ie,ne,k,nest,n,nc,np,lwrk,ier
c  ..array arguments..
      real*8 u(m),x(mx),xx(mx),db(nb),de(ne),w(m),t(nest),c(nc),wrk(lwrk
     *)
      real*8 cp(np)
      integer iwrk(nest)
c  ..local scalars..
      real*8 tol,dist
      integer i,ib1,ie1,ja,jb,jfp,jg,jq,jz,j,k1,k2,lwest,maxit,nmin,
     * ncc,kk,mmin,nmax,mxx
c ..function references
      integer max0
c  ..
c  we set up the parameters tol and maxit
      maxit = 20
      tol = 0.1e-02
c  before starting computations a data check is made. if the input data
c  are invalid, control is immediately repassed to the calling program.
      ier = 10
      if(iopt.lt.(-1) .or. iopt.gt.1) go to 90
      if(idim.le.0 .or. idim.gt.10) go to 90
      if(k.le.0 .or. k.gt.5) go to 90
      k1 = k+1
      kk = k1/2
      if(kk*2.ne.k1) go to 90
      k2 = k1+1
      if(ib.lt.0 .or. ib.gt.kk) go to 90
      if(ie.lt.0 .or. ie.gt.kk) go to 90
      nmin = 2*k1
      ib1 = max0(0,ib-1)
      ie1 = max0(0,ie-1)
      mmin = k1-ib1-ie1
      if(m.lt.mmin .or. nest.lt.nmin) go to 90
      if(nb.lt.(idim*ib) .or. ne.lt.(idim*ie)) go to 90
      if(np.lt.(2*k1*idim)) go to 90
      mxx = m*idim
      ncc = nest*idim
      if(mx.lt.mxx .or. nc.lt.ncc) go to 90
      lwest = m*k1+nest*(6+idim+3*k)
      if(lwrk.lt.lwest) go to 90
      if(w(1).le.0.) go to 90
      do 10 i=2,m
         if(u(i-1).ge.u(i) .or. w(i).le.0.) go to 90
  10  continue
      if(iopt.ge.0) go to 30
      if(n.lt.nmin .or. n.gt.nest) go to 90
      j = n
      do 20 i=1,k1
         t(i) = u(1)
         t(j) = u(m)
         j = j-1
  20  continue
      call fpched(u,m,t,n,k,ib,ie,ier)
      if (ier.eq.0) go to 40
      go to 90
  30  if(s.lt.0.) go to 90
      nmax = m+k1+ib1+ie1
      if(s.eq.0. .and. nest.lt.nmax) go to 90
      ier = 0
      if(iopt.gt.0) go to 70
c  we determine a polynomial curve satisfying the boundary constraints.
  40  call fppocu(idim,k,u(1),u(m),ib,db,nb,ie,de,ne,cp,np)
c  we generate new data points which will be approximated by a spline
c  with zero derivative constraints.
      j = nmin
      do 50 i=1,k1
        wrk(i) = u(1)
        wrk(j) = u(m)
        j = j-1
  50  continue
c  evaluate the polynomial curve
      call curev(idim,wrk,nmin,cp,np,k,u,m,xx,mxx,ier)
c  substract from the old data, the values of the polynomial curve
      do 60 i=1,mxx
        xx(i) = x(i)-xx(i)
  60  continue
c we partition the working space and determine the spline curve.
  70  jfp = 1
      jz = jfp+nest
      ja = jz+ncc
      jb = ja+nest*k1
      jg = jb+nest*k2
      jq = jg+nest*k2
      call fpcons(iopt,idim,m,u,mxx,xx,w,ib,ie,k,s,nest,tol,maxit,k1,
     * k2,n,t,ncc,c,fp,wrk(jfp),wrk(jz),wrk(ja),wrk(jb),wrk(jg),wrk(jq),
     *
     * iwrk,ier)
c  add the polynomial curve to the calculated spline.
      call fpadpo(idim,t,n,c,ncc,k,cp,np,wrk(jz),wrk(ja),wrk(jb))
  90  return
      end


c
c     file tmud2.f
c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1999 by UCAR                 .
c  .                                                             .
c  .       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                      MUDPACK version 5.0                    .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... author and specialist
c
c          John C. Adams (National Center for Atmospheric Research)
c          email: johnad@ucar.edu, phone: 303-497-1213

c ... For MUDPACK 5.0 information, visit the website:
c     (http://www.scd.ucar.edu/css/software/mudpack)
c
c
c ... purpose
c
c     test program for the MUDPACK solver mud2
c
c ... required MUDPACK files
c
c     mud2.f, mudcom.f
c
c *********************************************************
c *********************************************************
c
c     sample program/test driver for mud2
c
c **********************************************************
c **********************************************************
c
c     a sample program/test driver for mud2 is below. it can be
c     executed as an initial test.  output is listed for the test
c     case.  test mud2 by solving the elliptic pde
c
c          (1.+y**2)*pxx + exp(-(x+y))*(pyy-py) - (x+y)*pe = r(x,y)
c
c     on the unit square with specified boundary conditions at
c     xb = 1.0, yc = 0.0 and mixed boundary conditions
c
c          dp/dx - y*p(0,y) = g(y)  (at x=0.)
c
c     and
c
c          dp/dy + x*p(x,1) = h(x)  (at y=1.).
c
c     use line relaxation in the y direction and choose a grid as close
c     to 50 by 100 as the grid size arguments allow. use the exact
c     solution
c
c          pe(x,y) = x**5 + y**5 + 1.0
c
c     for testing.  one full multigrid cycle (no initial guess) with
c     the default multigrid options is executed and reaches discretization
c     level error.
c
c
c ******************************************************************
c     output (32 bit floating point arithmetic)
c ******************************************************************
c
c     mud2 test
c
c     integer input arguments
c     intl =  0 nxa =  2 nxb =  1 nyc =  1 nyd =  2
c     ixp =  3 jyq =  3 iex =  5 jey =  6
c     nx =  49 ny =  97 iguess =  0 maxcy =  1
c     method =  2 work space estimate =   83964
c
c     multigrid option arguments
c     kcycle =  2
c     iprer =  2
c     ipost =  1
c     intpol =  1
c
c     floating point input parameters
c     xa =  0.000 xb =  1.000 yc =  0.000 yd =  1.000
c     tolerance (error control) =    0.000E+00
c
c     discretization call to mud2 intl =  0
c     ierror =  0 minimum work space =   70048
c
c     approximation call to mud2
c     intl =  1 method =  2 iguess =  0
c     ierror =  0
c     maximum error  =   0.333E-03
c
c ************************************************************
c     end of output
c ************************************************************
c
c
      program tmud2
      implicit none
      integer iixp,jjyq,iiex,jjey,nnx,nny,isx,jsy,llwork
c
c     set grid sizes with parameter statements
c
      parameter (iixp = 3 , jjyq = 3 , iiex = 5, jjey = 6)
      parameter (nnx=iixp*2**(iiex-1)+1, nny=jjyq*2**(jjey-1)+1)
c
c     set work space length approximation for line-y relaxation (see mud2.d)
c
      parameter(isx=0,jsy=3)
      parameter (llwork=4*(nnx*nny*(10+isx+jsy)+8*(nnx+nny+2))/3)
      real(8) phi(nnx,nny),rhs(nnx,nny),work(llwork)
c
c     put integer and floating point argument names in contiguous
c     storeage for labelling in vectors iprm,fprm
c
      integer iprm(16),mgopt(4)
      real(8) fprm(6)
      integer intl,nxa,nxb,nyc,nyd,ixp,jyq,iex,jey,nx,ny,
     +              iguess,maxcy,method,nwork,lwrkqd,itero
      common/itmud2/intl,nxa,nxb,nyc,nyd,ixp,jyq,iex,jey,nx,ny,
     +              iguess,maxcy,method,nwork,lwrkqd,itero
      real(8) xa,xb,yc,yd,tolmax,relmax
      common/ftmud2/xa,xb,yc,yd,tolmax,relmax
      equivalence(intl,iprm)
      equivalence(xa,fprm)
      integer i,j,ierror
      real(8) dlx,dly,x,y,cxx,cyy,cx,cy,ce,pxx,pyy,px,py,pe,errmax
c
c     declare coefficient and boundary condition input subroutines external
c
      external cof,bndc
c
c
c     set input integer arguments
c
      intl = 0
c
c     set boundary condition flags
c
      nxa = 2
      nxb = 1
      nyc = 1
      nyd = 2
c
c     set grid sizes from parameter statements
c
      ixp = iixp
      jyq = jjyq
      iex = iiex
      jey = jjey
      nx = nnx
      ny = nny
c
c     set multigrid arguments (w(2,1) cycling with fully weighted
c     residual restriction and cubic prolongation)
c
      mgopt(1) = 2
      mgopt(2) = 2
      mgopt(3) = 1
      mgopt(4) = 3
c
c     set for one cycle
c
      maxcy = 1
c
c     set no initial guess forcing full multigrid cycling
c
      iguess = 0
c
c     set work space length approximation from parameter statement
c
      nwork = llwork
c
c     set line-y relaxation
c
      method = 2
c
c     set end points of solution rectangle in (x,y) space
c
      xa = 0d0
      xb = 1d0
      yc = 0d0
      yd = 1d0
c
c     set mesh increments
c
      dlx = (xb-xa)/(nx-1)
      dly = (yd-yc)/(ny-1)
c
c     set for no error control flag
c
      tolmax = 0d0
c
c     set right hand side in rhs
c     initialize phi to zero
c
      do i=1,nx
      x = xa+(i-1)*dlx
      do j=1,ny
        y = yc+(j-1)*dly
        call cof(x,y,cxx,cyy,cx,cy,ce)
        call exact(x,y,pxx,pyy,px,py,pe)
        rhs(i,j) = cxx*pxx+cyy*pyy+cx*px+cy*py+ce*pe
        phi(i,j) = 0d0
      end do
      end do
c
c     set specified boundaries in phi
c
      x = xb
      do j=1,ny
      y = yc+(j-1)*dly
      call exact(x,y,pxx,pyy,px,py,pe)
      phi(nx,j) = pe
      end do
      y = yc
      do i=1,nx
      x = xa+(i-1)*dlx
      call exact(x,y,pxx,pyy,px,py,pe)
      phi(i,1) = pe
      end do
      write(*,100)
  100 format(//' mud2 test ')
      write (*,101) (iprm(i),i=1,15)
  101 format(/' integer input arguments ',
     +/' intl = ',i2,' nxa = ',i2,' nxb = ',i2,' nyc = ',i2,
     + 'nyd = ',i2,
     +/' ixp = ',i2,' jyq = ',i2,' iex = ',i2,' jey = ',i2,
     +/' nx = ',i3,' ny = ',i3,' iguess = ',i2,' maxcy = ',i2,
     +/' method = ',i2, ' work space estimate = ',i7)
      write (*,102) (mgopt(i),i=1,4)
  102 format(/' multigrid option arguments ',
     +/' kcycle = ',i2,
     +/' iprer = ',i2,
     +/' ipost = ',i2,
     +/' intpol = ',i2)
      write(*,103) xa,xb,yc,yd,tolmax
  103 format(/' floating point input parameters ',
     +/' xa = ',f6.3,' xb = ',f6.3,' yc = ',f6.3,' yd = ',f6.3,
     +/' tolerance (error control) =   ',e10.3)
c
c     intiialization call
c
      write(*,104) intl
  104 format(/' discretization call to mud2', ' intl = ', i2)
      call mud2(iprm,fprm,work,cof,bndc,rhs,phi,mgopt,ierror)
c
c     print error parameter and minimum work space requirement
c
      write (*,105) ierror,iprm(16)
  105 format(' ierror = ',i2, ' minimum work space = ',i7)
      if (ierror.gt.0) call exit(0)
c
c     attempt solution
c
      intl = 1
      write(*,106) intl,method,iguess
  106 format(/' approximation call to mud2',
     +/' intl = ',i2, ' method = ',i2,' iguess = ',i2)
      call mud2(iprm,fprm,work,cof,bndc,rhs,phi,mgopt,ierror)
      write (*,107) ierror
  107 format(' ierror = ',i2)
      if (ierror.gt.0) call exit(0)
c
c     compute and print maximum norm of error
c
      errmax = 0d0
      do j=1,ny
      y = yc+(j-1)*dly
      do i=1,nx
        x = xa+(i-1)*dlx
        call exact(x,y,pxx,pyy,px,py,pe)
        errmax = dmax1(errmax,abs((phi(i,j)-pe)))
      end do
      end do
      write(*,108) errmax
  108 format(' maximum error  =  ',e10.3)
      end

      subroutine cof(x,y,cxx,cyy,cx,cy,ce)
c
c     input pde coefficients at any grid point (x,y) in the solution region
c
      implicit none
      real(8) x,y,cxx,cyy,cx,cy,ce
      cxx = 1.+y*y
      cyy = exp(-(x+y))
      cx = 0.0d0
      cy = -cyy
      ce = -(x+y)
      return
      end

      subroutine bndc(kbdy,xory,alfa,gbdy)
c
c     input mixed derivative b.c. to mud2
c
      implicit none
      integer kbdy
      real(8) xory,alfa,gbdy,x,y,pe,px,py,pxx,pyy
      real(8) xa,xb,yc,yd,tolmax,relmax
      common/ftmud2/xa,xb,yc,yd,tolmax,relmax
      if (kbdy.eq.1) then  ! x=xa boundary
      y = xory
      x = xa
      call exact(x,y,pxx,pyy,px,py,pe)
      alfa = -y
      gbdy = px + alfa*pe
      return
      end if
      if (kbdy.eq.4) then  ! y=yd boundary
      y = yd
      x = xory
      call exact(x,y,pxx,pyy,px,py,pe)
      alfa = x
      gbdy = py + alfa*pe
      return
      end if
      end

      subroutine exact(x,y,pxx,pyy,px,py,pe)
c
c     this subroutine is used to set an exact solution for testing mud2
c
      implicit none
      real(8) x,y,pxx,pyy,px,py,pe
      pe = x**5+y**5+1.
      px = 5.*x**4
      py = 5.*y**4
      pxx = 20.*x**3
      pyy = 20.*y**3
      return
      end


      subroutine heapsort(face,n)
c
c  Ordina in senso crescente il vettore intero face
c
      implicit none
      integer  node,i,j,k,ik,jk
      integer  n
      integer  face(5,n)
      logical  conf_fac
c
      do node = 2,n
         i = node
         j = i/2
         do while((i.ne.1).and.(conf_fac(face(1,j),face(1,i))))
            call swap_t(face(1,j),face(1,i))
            i = j
            j = i/2
         end do
      end do
c
      do i = n,2,-1
         call swap_t(face(1,i),face(1,1))
         k = i-1
         ik = 1
         jk = 2
         if ((k.ge.3).and.(conf_fac(face(1,2),face(1,3))))  jk = 3
         do while ((jk.le.k).and.(conf_fac(face(1,ik),face(1,jk))))
            call swap_t(face(1,jk),face(1,ik))
            ik = jk
            jk = ik*2
            if ((jk+1.le.k).and.(conf_fac(face(1,jk),face(1,jk+1))))
     1         jk = jk+1
         end do
      end do
c
      return
c
      end


! backtrack.f90 --
!    Module implementing a simple backtracking mechanism
!
!    The prime routine defined here requires four
!    user-defined routines and a suitable data structure
!    The data structure (derived type) is to be defined via the
!    module "backtracking_data" and is to be called
!    "SOLUTION_DATA".
!    This structure contains all there is to know about
!    the (partial) solutions that will be expanded as
!    the algorithm proceeds
!
!    The subroutines and functions are:
!
!        generate    Subroutine to generate the solutions
!        acceptable  Function to check a solution
!        free        Subroutine to free any memory
!                    associated with solutions
!        collect     Subroutine to collect solutions
!
!    Note:
!    The data need to be defined in the parate module,
!    because of the interface definitions
!
!    For example:
!    For the eight queens problem, the solution consists
!    of the position of the queens on at most 8 columns
!        module backtracking_data
!            implicit none
!            type SOLUTION_DATA
!                integer, dimension(8) :: row
!             end type SOLUTION_DATA
!        end module backtracking_data
!
module backtracking
    use backtracking_data
    implicit none
contains

! bt_solve --
!     Subroutine to run the backtracking algorithm
! Arguments:
!     base        Base solution or solutions
!     nostage     Number of stages
!     generate    Subroutine to generate the solutions
!     acceptable  Function to check a solution
!     free        Subroutine to free any memory
!                 associated with solutions
!     collect     Subroutine to collect solutions
!     stage_priv  Current stage (hidden)
!
recursive subroutine bt_solve( base, nostage, generate, acceptable, free, collect, stage_priv )
    type(SOLUTION_DATA), dimension(:) :: base
    integer, intent(in)               :: nostage
    integer, intent(in), optional     :: stage_priv

    interface
        subroutine generate( base, stage, solutions )
            use backtracking_data
            type(SOLUTION_DATA), intent(in)             :: base
            integer, intent(in)                         :: stage
            type(SOLUTION_DATA), dimension(:), pointer  :: solutions
        end subroutine generate
    end interface
    interface
        subroutine free( solutions )
            use backtracking_data
            type(SOLUTION_DATA), dimension(:), pointer  :: solutions
        end subroutine free
    end interface
    interface
        logical function acceptable( solution, stage )
            use backtracking_data
            type(SOLUTION_DATA), intent(in) :: solution
            integer, intent(in)             :: stage
        end function acceptable
    end interface
    interface
        subroutine collect( solution, stop )
            use backtracking_data
            type(SOLUTION_DATA), intent(in) :: solution
            logical, intent(out)            :: stop
        end subroutine collect
    end interface

    logical :: accept
    logical :: stop
    integer :: i
    integer :: stage
    type(SOLUTION_DATA), dimension(:), pointer  :: new_solutions

    if ( present(stage_priv) ) then
        stage = stage_priv
    else
        stage = 0
    endif

    !
    ! For each base solution:
    ! 1. If we are starting the search (stage = 0), then
    !    accept all incoming base solutions
    ! 2. If we have reached the last stage, the acceptable base
    !    solutions are real solutions
    ! 3. Otherwise, they can be used to generate new solutions
    !

    do i = 1,size(base)
        accept = (stage == 0)
        if ( .not. accept) accept = acceptable( base(i), stage )
        if ( accept ) then
            if ( stage == nostage ) then
                call collect( base(i), stop )
                if ( stop ) then
                    return
                endif
            else
                call generate( base(i), stage+1, new_solutions )
                call bt_solve( new_solutions, nostage, generate, acceptable, free, collect, stage+1 )
                call free( new_solutions )
            endif
        endif
    enddo
end subroutine bt_solve

end module backtracking


! This example is for a typical case of read/write to an n-d array of floating point numbers
! it overwrites existing "filename", since it is the simplest example
! https://support.hdfgroup.org/HDF5/doc/HL/RM_H5LT.html
program hdf5simple
use, intrinsic:: iso_fortran_env, only: dp=>real64
use h5mod, only: h5write

implicit none
! -------- user parameters -----------
character(*), parameter :: filename = "simple.h5" ,& ! file name
                            dsname = "1toN"          ! dataset name
real(dp), allocatable :: array(:)
integer :: length,ioerr
character(8) :: argv  ! just to keep maximum file size less than about a gigabyte (sanity check)
!-------------------------------------------------

call get_command_argument(1,argv,status=ioerr)
if(ioerr/=0) error stop 'please input array length'
read(argv,'(I8)') length
allocate(array(length))
array = fakedata(length)

call h5write(filename,dsname,array)

contains

function fakedata(length)
  integer, intent(in) :: length
  integer :: i
  real(dp) :: fakedata(length)

  do concurrent (i = 1:length)
    fakedata(i) = real(i,dp)
  end do

end function fakedata

end program


! { dg-do compile }
! { dg-require-effective-target vect_double }
      SUBROUTINE CALC2
      IMPLICIT REAL*8	(A-H, O-Z)
      PARAMETER (N1=1335, N2=1335)

      COMMON  U(N1,N2), V(N1,N2), P(N1,N2),
     *        UNEW(N1,N2), VNEW(N1,N2),
     1        PNEW(N1,N2), UOLD(N1,N2),
     *        VOLD(N1,N2), POLD(N1,N2),
     2        CU(N1,N2), CV(N1,N2),
     *        Z(N1,N2), H(N1,N2), PSI(N1,N2)
      COMMON /CONS/ DT,TDT,DX,DY,A,ALPHA,ITMAX,MPRINT,M,N,MP1,
     1              NP1,EL,PI,TPI,DI,DJ,PCF
      TDTS8 = TDT/8.D0
      TDTSDX = TDT/DX
      TDTSDY = TDT/DY

      DO 200 J=1,N
      DO 200 I=1,M
      UNEW(I+1,J) = UOLD(I+1,J)+
     1    TDTS8*(Z(I+1,J+1)+Z(I+1,J))*(CV(I+1,J+1)+CV(I,J+1)+CV(I,J)
     2       +CV(I+1,J))-TDTSDX*(H(I+1,J)-H(I,J))
      VNEW(I,J+1) = VOLD(I,J+1)-TDTS8*(Z(I+1,J+1)+Z(I,J+1))
     1       *(CU(I+1,J+1)+CU(I,J+1)+CU(I,J)+CU(I+1,J))
     2       -TDTSDY*(H(I,J+1)-H(I,J))
      PNEW(I,J) = POLD(I,J)-TDTSDX*(CU(I+1,J)-CU(I,J))
     1       -TDTSDY*(CV(I,J+1)-CV(I,J))
  200 CONTINUE
      RETURN
      END
! { dg-final { scan-tree-dump-times "LOOP VECTORIZED" 1 "vect" } }


Module m_valnth
Integer, Parameter :: kdp = selected_real_kind(15)
public :: valnth
private :: kdp
private :: R_valnth, I_valnth, D_valnth
interface valnth
  module procedure d_valnth, r_valnth, i_valnth
end interface valnth
contains

Function D_valnth (XDONT, NORD) Result (valnth)
!  Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
! __________________________________________________________
!  This routine uses a pivoting strategy such as the one of
!  finding the median based on the quicksort algorithm, but
!  we skew the pivot choice to try to bring it to NORD as
!  fast as possible. It uses 2 temporary arrays, where it
!  stores the indices of the values smaller than the pivot
!  (ILOWT), and the indices of values larger than the pivot
!  that we might still need later on (IHIGT). It iterates
!  until it can bring the number of values in ILOWT to
!  exactly NORD, and then finds the maximum of this set.
!  Michel Olagnon - Aug. 2000
! __________________________________________________________
! __________________________________________________________
      Real (Kind=kdp), Dimension (:), Intent (In) :: XDONT
      Real (Kind=kdp) :: valnth
      Integer, Intent (In) :: NORD
! __________________________________________________________
      Real (Kind=kdp), Dimension (SIZE(XDONT)) :: XLOWT, XHIGT
      Real (Kind=kdp) :: XPIV, XPIV0, XWRK, XWRK1, XWRK2, XWRK3, XMIN, XMAX
!
      Integer :: NDON, JHIG, JLOW, IHIG
      Integer :: IMIL, IFIN, ICRS, IDCR, ILOW
      Integer :: JLM2, JLM1, JHM2, JHM1, INTH
!
      NDON = SIZE (XDONT)
      INTH = MAX (MIN (NORD, NDON), 1)
!
!    First loop is used to fill-in XLOWT, XHIGT at the same time
!
      If (NDON < 2) Then
         If (INTH == 1) VALNTH = XDONT (1)
         Return
      End If
!
!  One chooses a pivot, best estimate possible to put fractile near
!  mid-point of the set of low values.
!
      If (XDONT(2) < XDONT(1)) Then
         XLOWT (1) = XDONT(2)
         XHIGT (1) = XDONT(1)
      Else
         XLOWT (1) = XDONT(1)
         XHIGT (1) = XDONT(2)
      End If
!
      If (NDON < 3) Then
         If (INTH == 1) VALNTH = XLOWT (1)
         If (INTH == 2) VALNTH = XHIGT (1)
         Return
      End If
!
      If (XDONT(3) < XHIGT(1)) Then
         XHIGT (2) = XHIGT (1)
         If (XDONT(3) < XLOWT(1)) Then
            XHIGT (1) = XLOWT (1)
            XLOWT (1) = XDONT(3)
         Else
            XHIGT (1) = XDONT(3)
         End If
      Else
         XHIGT (2) = XDONT(3)
      End If
!
      If (NDON < 4) Then
         If (INTH == 1) Then
             VALNTH = XLOWT (1)
         Else
             VALNTH = XHIGT (INTH - 1)
         End If
         Return
      End If
!
      If (XDONT(NDON) < XHIGT(1)) Then
         XHIGT (3) = XHIGT (2)
         XHIGT (2) = XHIGT (1)
         If (XDONT(NDON) < XLOWT(1)) Then
            XHIGT (1) = XLOWT (1)
            XLOWT (1) = XDONT(NDON)
         Else
            XHIGT (1) = XDONT(NDON)
         End If
      Else
         XHIGT (3) = XDONT(NDON)
      End If
!
      If (NDON < 5) Then
         If (INTH == 1) Then
             VALNTH = XLOWT (1)
         Else
             VALNTH = XHIGT (INTH - 1)
         End If
         Return
      End If
!

      JLOW = 1
      JHIG = 3
      XPIV = XLOWT(1) + REAL(2*INTH)/REAL(NDON+INTH) * (XHIGT(3)-XLOWT(1))
      If (XPIV >= XHIGT(1)) Then
         XPIV = XLOWT(1) + REAL(2*INTH)/REAL(NDON+INTH) * &
                           (XHIGT(2)-XLOWT(1))
         If (XPIV >= XHIGT(1)) &
             XPIV = XLOWT(1) + REAL (2*INTH) / REAL (NDON+INTH) * &
                               (XHIGT(1)-XLOWT(1))
      End If
      XPIV0 = XPIV
!
!  One puts values > pivot in the end and those <= pivot
!  at the beginning. This is split in 2 cases, so that
!  we can skip the loop test a number of times.
!  As we are also filling in the work arrays at the same time
!  we stop filling in the XHIGT array as soon as we have more
!  than enough values in XLOWT.
!
!
      If (XDONT(NDON) > XPIV) Then
         ICRS = 3
         Do
            ICRS = ICRS + 1
            If (XDONT(ICRS) > XPIV) Then
               If (ICRS >= NDON) Exit
               JHIG = JHIG + 1
               XHIGT (JHIG) = XDONT(ICRS)
            Else
               JLOW = JLOW + 1
               XLOWT (JLOW) = XDONT(ICRS)
               If (JLOW >= INTH) Exit
            End If
         End Do
!
!  One restricts further processing because it is no use
!  to store more high values
!
         If (ICRS < NDON-1) Then
            Do
               ICRS = ICRS + 1
               If (XDONT(ICRS) <= XPIV) Then
                  JLOW = JLOW + 1
                  XLOWT (JLOW) = XDONT(ICRS)
               Else If (ICRS >= NDON) Then
                  Exit
               End If
            End Do
         End If
!
!
      Else
!
!  Same as above, but this is not as easy to optimize, so the
!  DO-loop is kept
!
         Do ICRS = 4, NDON - 1
            If (XDONT(ICRS) > XPIV) Then
               JHIG = JHIG + 1
               XHIGT (JHIG) = XDONT(ICRS)
            Else
               JLOW = JLOW + 1
               XLOWT (JLOW) = XDONT(ICRS)
               If (JLOW >= INTH) Exit
            End If
         End Do
!
         If (ICRS < NDON-1) Then
            Do
               ICRS = ICRS + 1
               If (XDONT(ICRS) <= XPIV) Then
                  If (ICRS >= NDON) Exit
                  JLOW = JLOW + 1
                  XLOWT (JLOW) = XDONT(ICRS)
               End If
            End Do
         End If
      End If
!
      JLM2 = 0
      JLM1 = 0
      JHM2 = 0
      JHM1 = 0
      Do
         If (JLM2 == JLOW .And. JHM2 == JHIG) Then
!
!   We are oscillating. Perturbate by bringing JLOW closer by one
!   to INTH
!
             If (INTH > JLOW) Then
                XMIN = XHIGT(1)
                IHIG = 1
                Do ICRS = 2, JHIG
                   If (XHIGT(ICRS) < XMIN) Then
                      XMIN = XHIGT(ICRS)
                      IHIG = ICRS
                   End If
                End Do
!
                JLOW = JLOW + 1
                XLOWT (JLOW) = XHIGT (IHIG)
                XHIGT (IHIG) = XHIGT (JHIG)
                JHIG = JHIG - 1
             Else

                XMAX = XLOWT (JLOW)
                JLOW = JLOW - 1
                Do ICRS = 1, JLOW
                   If (XLOWT(ICRS) > XMAX) Then
                      XWRK = XMAX
                      XMAX = XLOWT(ICRS)
                      XLOWT (ICRS) = XWRK
                   End If
                End Do
             End If
         End If
         JLM2 = JLM1
         JLM1 = JLOW
         JHM2 = JHM1
         JHM1 = JHIG
!
!   We try to bring the number of values in the low values set
!   closer to INTH.
!
         Select Case (INTH-JLOW)
         Case (2:)
!
!   Not enough values in low part, at least 2 are missing
!
            INTH = INTH - JLOW
            JLOW = 0
            Select Case (JHIG)
!!!!!           CASE DEFAULT
!!!!!              write (unit=*,fmt=*) "Assertion failed"
!!!!!              STOP
!
!   We make a special case when we have so few values in
!   the high values set that it is bad performance to choose a pivot
!   and apply the general algorithm.
!
            Case (2)
               If (XHIGT(1) <= XHIGT(2)) Then
                  JLOW = JLOW + 1
                  XLOWT (JLOW) = XHIGT (1)
                  JLOW = JLOW + 1
                  XLOWT (JLOW) = XHIGT (2)
               Else
                  JLOW = JLOW + 1
                  XLOWT (JLOW) = XHIGT (2)
                  JLOW = JLOW + 1
                  XLOWT (JLOW) = XHIGT (1)
               End If
               Exit
!
            Case (3)
!
!
               XWRK1 = XHIGT (1)
               XWRK2 = XHIGT (2)
               XWRK3 = XHIGT (3)
               If (XWRK2 < XWRK1) Then
                  XHIGT (1) = XWRK2
                  XHIGT (2) = XWRK1
                  XWRK2 = XWRK1
               End If
               If (XWRK2 > XWRK3) Then
                  XHIGT (3) = XWRK2
                  XHIGT (2) = XWRK3
                  XWRK2 = XWRK3
                  If (XWRK2 < XHIGT(1)) Then
                     XHIGT (2) = XHIGT (1)
                     XHIGT (1) = XWRK2
                  End If
               End If
               JHIG = 0
               Do ICRS = JLOW + 1, INTH
                  JHIG = JHIG + 1
                  XLOWT (ICRS) = XHIGT (JHIG)
               End Do
               JLOW = INTH
               Exit
!
            Case (4:)
!
!
               XPIV0 = XPIV
               IFIN = JHIG
!
!  One chooses a pivot from the 2 first values and the last one.
!  This should ensure sufficient renewal between iterations to
!  avoid worst case behavior effects.
!
               XWRK1 = XHIGT (1)
               XWRK2 = XHIGT (2)
               XWRK3 = XHIGT (IFIN)
               If (XWRK2 < XWRK1) Then
                  XHIGT (1) = XWRK2
                  XHIGT (2) = XWRK1
                  XWRK2 = XWRK1
               End If
               If (XWRK2 > XWRK3) Then
                  XHIGT (IFIN) = XWRK2
                  XHIGT (2) = XWRK3
                  XWRK2 = XWRK3
                  If (XWRK2 < XHIGT(1)) Then
                     XHIGT (2) = XHIGT (1)
                     XHIGT (1) = XWRK2
                  End If
               End If
!
               XWRK1 = XHIGT (1)
               JLOW = JLOW + 1
               XLOWT (JLOW) = XWRK1
               XPIV = XWRK1 + 0.5 * (XHIGT(IFIN)-XWRK1)
!
!  One takes values <= pivot to XLOWT
!  Again, 2 parts, one where we take care of the remaining
!  high values because we might still need them, and the
!  other when we know that we will have more than enough
!  low values in the end.
!
               JHIG = 0
               Do ICRS = 2, IFIN
                  If (XHIGT(ICRS) <= XPIV) Then
                     JLOW = JLOW + 1
                     XLOWT (JLOW) = XHIGT (ICRS)
                     If (JLOW >= INTH) Exit
                  Else
                     JHIG = JHIG + 1
                     XHIGT (JHIG) = XHIGT (ICRS)
                  End If
               End Do
!
               Do ICRS = ICRS + 1, IFIN
                  If (XHIGT(ICRS) <= XPIV) Then
                     JLOW = JLOW + 1
                     XLOWT (JLOW) = XHIGT (ICRS)
                  End If
               End Do
            End Select
!
!
         Case (1)
!
!  Only 1 value is missing in low part
!
            XMIN = XHIGT(1)
            IHIG = 1
            Do ICRS = 2, JHIG
               If (XHIGT(ICRS) < XMIN) Then
                  XMIN = XHIGT(ICRS)
                  IHIG = ICRS
               End If
            End Do
!
            VALNTH = XHIGT (IHIG)
            Return
!
!
         Case (0)
!
!  Low part is exactly what we want
!
            Exit
!
!
         Case (-5:-1)
!
!  Only few values too many in low part
!
            XHIGT (1) = XLOWT (1)
            ILOW = 1 + INTH - JLOW
            Do ICRS = 2, INTH
               XWRK = XLOWT (ICRS)
               Do IDCR = ICRS - 1, MAX (1, ILOW), - 1
                  If (XWRK < XHIGT(IDCR)) Then
                     XHIGT (IDCR+1) = XHIGT (IDCR)
                  Else
                     Exit
                  End If
               End Do
               XHIGT (IDCR+1) = XWRK
               ILOW = ILOW + 1
            End Do
!
            XWRK1 = XHIGT(INTH)
            ILOW = 2*INTH - JLOW
            Do ICRS = INTH + 1, JLOW
               If (XLOWT (ICRS) < XWRK1) Then
                  XWRK = XLOWT (ICRS)
                  Do IDCR = INTH - 1, MAX (1, ILOW), - 1
                     If (XWRK >= XHIGT(IDCR)) Exit
                     XHIGT (IDCR+1) = XHIGT (IDCR)
                  End Do
                  XHIGT (IDCR+1) = XLOWT (ICRS)
                  XWRK1 = XHIGT(INTH)
               End If
               ILOW = ILOW + 1
            End Do
!
            VALNTH = XHIGT(INTH)
            Return
!
!
         Case (:-6)
!
! last case: too many values in low part
!

            IMIL = (JLOW+1) / 2
            IFIN = JLOW
!
!  One chooses a pivot from 1st, last, and middle values
!
            If (XLOWT(IMIL) < XLOWT(1)) Then
               XWRK = XLOWT (1)
               XLOWT (1) = XLOWT (IMIL)
               XLOWT (IMIL) = XWRK
            End If
            If (XLOWT(IMIL) > XLOWT(IFIN)) Then
               XWRK = XLOWT (IFIN)
               XLOWT (IFIN) = XLOWT (IMIL)
               XLOWT (IMIL) = XWRK
               If (XLOWT(IMIL) < XLOWT(1)) Then
                  XWRK = XLOWT (1)
                  XLOWT (1) = XLOWT (IMIL)
                  XLOWT (IMIL) = XWRK
               End If
            End If
            If (IFIN <= 3) Exit
!
            XPIV = XLOWT(1) + REAL(INTH)/REAL(JLOW+INTH) * &
                              (XLOWT(IFIN)-XLOWT(1))

!
!  One takes values > XPIV to XHIGT
!
            JHIG = 0
            JLOW = 0
!
            If (XLOWT(IFIN) > XPIV) Then
               ICRS = 0
               Do
                  ICRS = ICRS + 1
                  If (XLOWT(ICRS) > XPIV) Then
                     JHIG = JHIG + 1
                     XHIGT (JHIG) = XLOWT (ICRS)
                     If (ICRS >= IFIN) Exit
                  Else
                     JLOW = JLOW + 1
                     XLOWT (JLOW) = XLOWT (ICRS)
                     If (JLOW >= INTH) Exit
                  End If
               End Do
!
               If (ICRS < IFIN) Then
                  Do
                     ICRS = ICRS + 1
                     If (XLOWT(ICRS) <= XPIV) Then
                        JLOW = JLOW + 1
                        XLOWT (JLOW) = XLOWT (ICRS)
                     Else
                        If (ICRS >= IFIN) Exit
                     End If
                  End Do
               End If
            Else
               Do ICRS = 1, IFIN
                  If (XLOWT(ICRS) > XPIV) Then
                     JHIG = JHIG + 1
                     XHIGT (JHIG) = XLOWT (ICRS)
                  Else
                     JLOW = JLOW + 1
                     XLOWT (JLOW) = XLOWT (ICRS)
                     If (JLOW >= INTH) Exit
                  End If
               End Do
!
               Do ICRS = ICRS + 1, IFIN
                  If (XLOWT(ICRS) <= XPIV) Then
                     JLOW = JLOW + 1
                     XLOWT (JLOW) = XLOWT (ICRS)
                  End If
               End Do
            End If
!
         End Select
!
      End Do
!
!  Now, we only need to find maximum of the 1:INTH set
!
      VALNTH = MAXVAL (XLOWT (1:INTH))
      Return
!
!
End Function D_valnth

Function R_valnth (XDONT, NORD) Result (valnth)
!  Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
! __________________________________________________________
!  This routine uses a pivoting strategy such as the one of
!  finding the median based on the quicksort algorithm, but
!  we skew the pivot choice to try to bring it to NORD as
!  fast as possible. It uses 2 temporary arrays, where it
!  stores the indices of the values smaller than the pivot
!  (ILOWT), and the indices of values larger than the pivot
!  that we might still need later on (IHIGT). It iterates
!  until it can bring the number of values in ILOWT to
!  exactly NORD, and then finds the maximum of this set.
!  Michel Olagnon - Aug. 2000
! __________________________________________________________
! _________________________________________________________
      Real, Dimension (:), Intent (In) :: XDONT
      Real :: valnth
      Integer, Intent (In) :: NORD
! __________________________________________________________
      Real, Dimension (SIZE(XDONT)) :: XLOWT, XHIGT
      Real :: XPIV, XPIV0, XWRK, XWRK1, XWRK2, XWRK3, XMIN, XMAX
!
      Integer :: NDON, JHIG, JLOW, IHIG
      Integer :: IMIL, IFIN, ICRS, IDCR, ILOW
      Integer :: JLM2, JLM1, JHM2, JHM1, INTH
!
      NDON = SIZE (XDONT)
      INTH = MAX (MIN (NORD, NDON), 1)
!
!    First loop is used to fill-in XLOWT, XHIGT at the same time
!
      If (NDON < 2) Then
         If (INTH == 1) VALNTH = XDONT (1)
         Return
      End If
!
!  One chooses a pivot, best estimate possible to put fractile near
!  mid-point of the set of low values.
!
      If (XDONT(2) < XDONT(1)) Then
         XLOWT (1) = XDONT(2)
         XHIGT (1) = XDONT(1)
      Else
         XLOWT (1) = XDONT(1)
         XHIGT (1) = XDONT(2)
      End If
!
      If (NDON < 3) Then
         If (INTH == 1) VALNTH = XLOWT (1)
         If (INTH == 2) VALNTH = XHIGT (1)
         Return
      End If
!
      If (XDONT(3) < XHIGT(1)) Then
         XHIGT (2) = XHIGT (1)
         If (XDONT(3) < XLOWT(1)) Then
            XHIGT (1) = XLOWT (1)
            XLOWT (1) = XDONT(3)
         Else
            XHIGT (1) = XDONT(3)
         End If
      Else
         XHIGT (2) = XDONT(3)
      End If
!
      If (NDON < 4) Then
         If (INTH == 1) Then
             VALNTH = XLOWT (1)
         Else
             VALNTH = XHIGT (INTH - 1)
         End If
         Return
      End If
!
      If (XDONT(NDON) < XHIGT(1)) Then
         XHIGT (3) = XHIGT (2)
         XHIGT (2) = XHIGT (1)
         If (XDONT(NDON) < XLOWT(1)) Then
            XHIGT (1) = XLOWT (1)
            XLOWT (1) = XDONT(NDON)
         Else
            XHIGT (1) = XDONT(NDON)
         End If
      Else
         XHIGT (3) = XDONT(NDON)
      End If
!
      If (NDON < 5) Then
         If (INTH == 1) Then
             VALNTH = XLOWT (1)
         Else
             VALNTH = XHIGT (INTH - 1)
         End If
         Return
      End If
!

      JLOW = 1
      JHIG = 3
      XPIV = XLOWT(1) + REAL(2*INTH)/REAL(NDON+INTH) * (XHIGT(3)-XLOWT(1))
      If (XPIV >= XHIGT(1)) Then
         XPIV = XLOWT(1) + REAL(2*INTH)/REAL(NDON+INTH) * &
                           (XHIGT(2)-XLOWT(1))
         If (XPIV >= XHIGT(1)) &
             XPIV = XLOWT(1) + REAL (2*INTH) / REAL (NDON+INTH) * &
                               (XHIGT(1)-XLOWT(1))
      End If
      XPIV0 = XPIV
!
!  One puts values > pivot in the end and those <= pivot
!  at the beginning. This is split in 2 cases, so that
!  we can skip the loop test a number of times.
!  As we are also filling in the work arrays at the same time
!  we stop filling in the XHIGT array as soon as we have more
!  than enough values in XLOWT.
!
!
      If (XDONT(NDON) > XPIV) Then
         ICRS = 3
         Do
            ICRS = ICRS + 1
            If (XDONT(ICRS) > XPIV) Then
               If (ICRS >= NDON) Exit
               JHIG = JHIG + 1
               XHIGT (JHIG) = XDONT(ICRS)
            Else
               JLOW = JLOW + 1
               XLOWT (JLOW) = XDONT(ICRS)
               If (JLOW >= INTH) Exit
            End If
         End Do
!
!  One restricts further processing because it is no use
!  to store more high values
!
         If (ICRS < NDON-1) Then
            Do
               ICRS = ICRS + 1
               If (XDONT(ICRS) <= XPIV) Then
                  JLOW = JLOW + 1
                  XLOWT (JLOW) = XDONT(ICRS)
               Else If (ICRS >= NDON) Then
                  Exit
               End If
            End Do
         End If
!
!
      Else
!
!  Same as above, but this is not as easy to optimize, so the
!  DO-loop is kept
!
         Do ICRS = 4, NDON - 1
            If (XDONT(ICRS) > XPIV) Then
               JHIG = JHIG + 1
               XHIGT (JHIG) = XDONT(ICRS)
            Else
               JLOW = JLOW + 1
               XLOWT (JLOW) = XDONT(ICRS)
               If (JLOW >= INTH) Exit
            End If
         End Do
!
         If (ICRS < NDON-1) Then
            Do
               ICRS = ICRS + 1
               If (XDONT(ICRS) <= XPIV) Then
                  If (ICRS >= NDON) Exit
                  JLOW = JLOW + 1
                  XLOWT (JLOW) = XDONT(ICRS)
               End If
            End Do
         End If
      End If
!
      JLM2 = 0
      JLM1 = 0
      JHM2 = 0
      JHM1 = 0
      Do
         If (JLM2 == JLOW .And. JHM2 == JHIG) Then
!
!   We are oscillating. Perturbate by bringing JLOW closer by one
!   to INTH
!
             If (INTH > JLOW) Then
                XMIN = XHIGT(1)
                IHIG = 1
                Do ICRS = 2, JHIG
                   If (XHIGT(ICRS) < XMIN) Then
                      XMIN = XHIGT(ICRS)
                      IHIG = ICRS
                   End If
                End Do
!
                JLOW = JLOW + 1
                XLOWT (JLOW) = XHIGT (IHIG)
                XHIGT (IHIG) = XHIGT (JHIG)
                JHIG = JHIG - 1
             Else

                XMAX = XLOWT (JLOW)
                JLOW = JLOW - 1
                Do ICRS = 1, JLOW
                   If (XLOWT(ICRS) > XMAX) Then
                      XWRK = XMAX
                      XMAX = XLOWT(ICRS)
                      XLOWT (ICRS) = XWRK
                   End If
                End Do
             End If
         End If
         JLM2 = JLM1
         JLM1 = JLOW
         JHM2 = JHM1
         JHM1 = JHIG
!
!   We try to bring the number of values in the low values set
!   closer to INTH.
!
         Select Case (INTH-JLOW)
         Case (2:)
!
!   Not enough values in low part, at least 2 are missing
!
            INTH = INTH - JLOW
            JLOW = 0
            Select Case (JHIG)
!!!!!           CASE DEFAULT
!!!!!              write (unit=*,fmt=*) "Assertion failed"
!!!!!              STOP
!
!   We make a special case when we have so few values in
!   the high values set that it is bad performance to choose a pivot
!   and apply the general algorithm.
!
            Case (2)
               If (XHIGT(1) <= XHIGT(2)) Then
                  JLOW = JLOW + 1
                  XLOWT (JLOW) = XHIGT (1)
                  JLOW = JLOW + 1
                  XLOWT (JLOW) = XHIGT (2)
               Else
                  JLOW = JLOW + 1
                  XLOWT (JLOW) = XHIGT (2)
                  JLOW = JLOW + 1
                  XLOWT (JLOW) = XHIGT (1)
               End If
               Exit
!
            Case (3)
!
!
               XWRK1 = XHIGT (1)
               XWRK2 = XHIGT (2)
               XWRK3 = XHIGT (3)
               If (XWRK2 < XWRK1) Then
                  XHIGT (1) = XWRK2
                  XHIGT (2) = XWRK1
                  XWRK2 = XWRK1
               End If
               If (XWRK2 > XWRK3) Then
                  XHIGT (3) = XWRK2
                  XHIGT (2) = XWRK3
                  XWRK2 = XWRK3
                  If (XWRK2 < XHIGT(1)) Then
                     XHIGT (2) = XHIGT (1)
                     XHIGT (1) = XWRK2
                  End If
               End If
               JHIG = 0
               Do ICRS = JLOW + 1, INTH
                  JHIG = JHIG + 1
                  XLOWT (ICRS) = XHIGT (JHIG)
               End Do
               JLOW = INTH
               Exit
!
            Case (4:)
!
!
               XPIV0 = XPIV
               IFIN = JHIG
!
!  One chooses a pivot from the 2 first values and the last one.
!  This should ensure sufficient renewal between iterations to
!  avoid worst case behavior effects.
!
               XWRK1 = XHIGT (1)
               XWRK2 = XHIGT (2)
               XWRK3 = XHIGT (IFIN)
               If (XWRK2 < XWRK1) Then
                  XHIGT (1) = XWRK2
                  XHIGT (2) = XWRK1
                  XWRK2 = XWRK1
               End If
               If (XWRK2 > XWRK3) Then
                  XHIGT (IFIN) = XWRK2
                  XHIGT (2) = XWRK3
                  XWRK2 = XWRK3
                  If (XWRK2 < XHIGT(1)) Then
                     XHIGT (2) = XHIGT (1)
                     XHIGT (1) = XWRK2
                  End If
               End If
!
               XWRK1 = XHIGT (1)
               JLOW = JLOW + 1
               XLOWT (JLOW) = XWRK1
               XPIV = XWRK1 + 0.5 * (XHIGT(IFIN)-XWRK1)
!
!  One takes values <= pivot to XLOWT
!  Again, 2 parts, one where we take care of the remaining
!  high values because we might still need them, and the
!  other when we know that we will have more than enough
!  low values in the end.
!
               JHIG = 0
               Do ICRS = 2, IFIN
                  If (XHIGT(ICRS) <= XPIV) Then
                     JLOW = JLOW + 1
                     XLOWT (JLOW) = XHIGT (ICRS)
                     If (JLOW >= INTH) Exit
                  Else
                     JHIG = JHIG + 1
                     XHIGT (JHIG) = XHIGT (ICRS)
                  End If
               End Do
!
               Do ICRS = ICRS + 1, IFIN
                  If (XHIGT(ICRS) <= XPIV) Then
                     JLOW = JLOW + 1
                     XLOWT (JLOW) = XHIGT (ICRS)
                  End If
               End Do
            End Select
!
!
         Case (1)
!
!  Only 1 value is missing in low part
!
            XMIN = XHIGT(1)
            IHIG = 1
            Do ICRS = 2, JHIG
               If (XHIGT(ICRS) < XMIN) Then
                  XMIN = XHIGT(ICRS)
                  IHIG = ICRS
               End If
            End Do
!
            VALNTH = XHIGT (IHIG)
            Return
!
!
         Case (0)
!
!  Low part is exactly what we want
!
            Exit
!
!
         Case (-5:-1)
!
!  Only few values too many in low part
!
            XHIGT (1) = XLOWT (1)
            ILOW = 1 + INTH - JLOW
            Do ICRS = 2, INTH
               XWRK = XLOWT (ICRS)
               Do IDCR = ICRS - 1, MAX (1, ILOW), - 1
                  If (XWRK < XHIGT(IDCR)) Then
                     XHIGT (IDCR+1) = XHIGT (IDCR)
                  Else
                     Exit
                  End If
               End Do
               XHIGT (IDCR+1) = XWRK
               ILOW = ILOW + 1
            End Do
!
            XWRK1 = XHIGT(INTH)
            ILOW = 2*INTH - JLOW
            Do ICRS = INTH + 1, JLOW
               If (XLOWT (ICRS) < XWRK1) Then
                  XWRK = XLOWT (ICRS)
                  Do IDCR = INTH - 1, MAX (1, ILOW), - 1
                     If (XWRK >= XHIGT(IDCR)) Exit
                     XHIGT (IDCR+1) = XHIGT (IDCR)
                  End Do
                  XHIGT (IDCR+1) = XLOWT (ICRS)
                  XWRK1 = XHIGT(INTH)
               End If
               ILOW = ILOW + 1
            End Do
!
            VALNTH = XHIGT(INTH)
            Return
!
!
         Case (:-6)
!
! last case: too many values in low part
!

            IMIL = (JLOW+1) / 2
            IFIN = JLOW
!
!  One chooses a pivot from 1st, last, and middle values
!
            If (XLOWT(IMIL) < XLOWT(1)) Then
               XWRK = XLOWT (1)
               XLOWT (1) = XLOWT (IMIL)
               XLOWT (IMIL) = XWRK
            End If
            If (XLOWT(IMIL) > XLOWT(IFIN)) Then
               XWRK = XLOWT (IFIN)
               XLOWT (IFIN) = XLOWT (IMIL)
               XLOWT (IMIL) = XWRK
               If (XLOWT(IMIL) < XLOWT(1)) Then
                  XWRK = XLOWT (1)
                  XLOWT (1) = XLOWT (IMIL)
                  XLOWT (IMIL) = XWRK
               End If
            End If
            If (IFIN <= 3) Exit
!
            XPIV = XLOWT(1) + REAL(INTH)/REAL(JLOW+INTH) * &
                              (XLOWT(IFIN)-XLOWT(1))

!
!  One takes values > XPIV to XHIGT
!
            JHIG = 0
            JLOW = 0
!
            If (XLOWT(IFIN) > XPIV) Then
               ICRS = 0
               Do
                  ICRS = ICRS + 1
                  If (XLOWT(ICRS) > XPIV) Then
                     JHIG = JHIG + 1
                     XHIGT (JHIG) = XLOWT (ICRS)
                     If (ICRS >= IFIN) Exit
                  Else
                     JLOW = JLOW + 1
                     XLOWT (JLOW) = XLOWT (ICRS)
                     If (JLOW >= INTH) Exit
                  End If
               End Do
!
               If (ICRS < IFIN) Then
                  Do
                     ICRS = ICRS + 1
                     If (XLOWT(ICRS) <= XPIV) Then
                        JLOW = JLOW + 1
                        XLOWT (JLOW) = XLOWT (ICRS)
                     Else
                        If (ICRS >= IFIN) Exit
                     End If
                  End Do
               End If
            Else
               Do ICRS = 1, IFIN
                  If (XLOWT(ICRS) > XPIV) Then
                     JHIG = JHIG + 1
                     XHIGT (JHIG) = XLOWT (ICRS)
                  Else
                     JLOW = JLOW + 1
                     XLOWT (JLOW) = XLOWT (ICRS)
                     If (JLOW >= INTH) Exit
                  End If
               End Do
!
               Do ICRS = ICRS + 1, IFIN
                  If (XLOWT(ICRS) <= XPIV) Then
                     JLOW = JLOW + 1
                     XLOWT (JLOW) = XLOWT (ICRS)
                  End If
               End Do
            End If
!
         End Select
!
      End Do
!
!  Now, we only need to find maximum of the 1:INTH set
!
      VALNTH = MAXVAL (XLOWT (1:INTH))
      Return
!
!
End Function R_valnth
Function I_valnth (XDONT, NORD) Result (valnth)
!  Return NORDth value of XDONT, i.e fractile of order NORD/SIZE(XDONT).
! __________________________________________________________
!  This routine uses a pivoting strategy such as the one of
!  finding the median based on the quicksort algorithm, but
!  we skew the pivot choice to try to bring it to NORD as
!  fast as possible. It uses 2 temporary arrays, where it
!  stores the indices of the values smaller than the pivot
!  (ILOWT), and the indices of values larger than the pivot
!  that we might still need later on (IHIGT). It iterates
!  until it can bring the number of values in ILOWT to
!  exactly NORD, and then finds the maximum of this set.
!  Michel Olagnon - Aug. 2000
! __________________________________________________________
! __________________________________________________________
      Integer, Dimension (:), Intent (In) :: XDONT
      Integer :: valnth
      Integer, Intent (In) :: NORD
! __________________________________________________________
      Integer, Dimension (SIZE(XDONT)) :: XLOWT, XHIGT
      Integer :: XPIV, XPIV0, XWRK, XWRK1, XWRK2, XWRK3, XMIN, XMAX
!
      Integer :: NDON, JHIG, JLOW, IHIG
      Integer :: IMIL, IFIN, ICRS, IDCR, ILOW
      Integer :: JLM2, JLM1, JHM2, JHM1, INTH
!
      NDON = SIZE (XDONT)
      INTH = MAX (MIN (NORD, NDON), 1)
!
!    First loop is used to fill-in XLOWT, XHIGT at the same time
!
      If (NDON < 2) Then
         If (INTH == 1) VALNTH = XDONT (1)
         Return
      End If
!
!  One chooses a pivot, best estimate possible to put fractile near
!  mid-point of the set of low values.
!
      If (XDONT(2) < XDONT(1)) Then
         XLOWT (1) = XDONT(2)
         XHIGT (1) = XDONT(1)
      Else
         XLOWT (1) = XDONT(1)
         XHIGT (1) = XDONT(2)
      End If
!
      If (NDON < 3) Then
         If (INTH == 1) VALNTH = XLOWT (1)
         If (INTH == 2) VALNTH = XHIGT (1)
         Return
      End If
!
      If (XDONT(3) < XHIGT(1)) Then
         XHIGT (2) = XHIGT (1)
         If (XDONT(3) < XLOWT(1)) Then
            XHIGT (1) = XLOWT (1)
            XLOWT (1) = XDONT(3)
         Else
            XHIGT (1) = XDONT(3)
         End If
      Else
         XHIGT (2) = XDONT(3)
      End If
!
      If (NDON < 4) Then
         If (INTH == 1) Then
             VALNTH = XLOWT (1)
         Else
             VALNTH = XHIGT (INTH - 1)
         End If
         Return
      End If
!
      If (XDONT(NDON) < XHIGT(1)) Then
         XHIGT (3) = XHIGT (2)
         XHIGT (2) = XHIGT (1)
         If (XDONT(NDON) < XLOWT(1)) Then
            XHIGT (1) = XLOWT (1)
            XLOWT (1) = XDONT(NDON)
         Else
            XHIGT (1) = XDONT(NDON)
         End If
      Else
         XHIGT (3) = XDONT(NDON)
      End If
!
      If (NDON < 5) Then
         If (INTH == 1) Then
             VALNTH = XLOWT (1)
         Else
             VALNTH = XHIGT (INTH - 1)
         End If
         Return
      End If
!

      JLOW = 1
      JHIG = 3
      XPIV = XLOWT(1) + REAL(2*INTH)/REAL(NDON+INTH) * (XHIGT(3)-XLOWT(1))
      If (XPIV >= XHIGT(1)) Then
         XPIV = XLOWT(1) + REAL(2*INTH)/REAL(NDON+INTH) * &
                           (XHIGT(2)-XLOWT(1))
         If (XPIV >= XHIGT(1)) &
             XPIV = XLOWT(1) + REAL (2*INTH) / REAL (NDON+INTH) * &
                               (XHIGT(1)-XLOWT(1))
      End If
      XPIV0 = XPIV
!
!  One puts values > pivot in the end and those <= pivot
!  at the beginning. This is split in 2 cases, so that
!  we can skip the loop test a number of times.
!  As we are also filling in the work arrays at the same time
!  we stop filling in the XHIGT array as soon as we have more
!  than enough values in XLOWT.
!
!
      If (XDONT(NDON) > XPIV) Then
         ICRS = 3
         Do
            ICRS = ICRS + 1
            If (XDONT(ICRS) > XPIV) Then
               If (ICRS >= NDON) Exit
               JHIG = JHIG + 1
               XHIGT (JHIG) = XDONT(ICRS)
            Else
               JLOW = JLOW + 1
               XLOWT (JLOW) = XDONT(ICRS)
               If (JLOW >= INTH) Exit
            End If
         End Do
!
!  One restricts further processing because it is no use
!  to store more high values
!
         If (ICRS < NDON-1) Then
            Do
               ICRS = ICRS + 1
               If (XDONT(ICRS) <= XPIV) Then
                  JLOW = JLOW + 1
                  XLOWT (JLOW) = XDONT(ICRS)
               Else If (ICRS >= NDON) Then
                  Exit
               End If
            End Do
         End If
!
!
      Else
!
!  Same as above, but this is not as easy to optimize, so the
!  DO-loop is kept
!
         Do ICRS = 4, NDON - 1
            If (XDONT(ICRS) > XPIV) Then
               JHIG = JHIG + 1
               XHIGT (JHIG) = XDONT(ICRS)
            Else
               JLOW = JLOW + 1
               XLOWT (JLOW) = XDONT(ICRS)
               If (JLOW >= INTH) Exit
            End If
         End Do
!
         If (ICRS < NDON-1) Then
            Do
               ICRS = ICRS + 1
               If (XDONT(ICRS) <= XPIV) Then
                  If (ICRS >= NDON) Exit
                  JLOW = JLOW + 1
                  XLOWT (JLOW) = XDONT(ICRS)
               End If
            End Do
         End If
      End If
!
      JLM2 = 0
      JLM1 = 0
      JHM2 = 0
      JHM1 = 0
      Do
         If (JLM2 == JLOW .And. JHM2 == JHIG) Then
!
!   We are oscillating. Perturbate by bringing JLOW closer by one
!   to INTH
!
             If (INTH > JLOW) Then
                XMIN = XHIGT(1)
                IHIG = 1
                Do ICRS = 2, JHIG
                   If (XHIGT(ICRS) < XMIN) Then
                      XMIN = XHIGT(ICRS)
                      IHIG = ICRS
                   End If
                End Do
!
                JLOW = JLOW + 1
                XLOWT (JLOW) = XHIGT (IHIG)
                XHIGT (IHIG) = XHIGT (JHIG)
                JHIG = JHIG - 1
             Else

                XMAX = XLOWT (JLOW)
                JLOW = JLOW - 1
                Do ICRS = 1, JLOW
                   If (XLOWT(ICRS) > XMAX) Then
                      XWRK = XMAX
                      XMAX = XLOWT(ICRS)
                      XLOWT (ICRS) = XWRK
                   End If
                End Do
             End If
         End If
         JLM2 = JLM1
         JLM1 = JLOW
         JHM2 = JHM1
         JHM1 = JHIG
!
!   We try to bring the number of values in the low values set
!   closer to INTH.
!
         Select Case (INTH-JLOW)
         Case (2:)
!
!   Not enough values in low part, at least 2 are missing
!
            INTH = INTH - JLOW
            JLOW = 0
            Select Case (JHIG)
!!!!!           CASE DEFAULT
!!!!!              write (unit=*,fmt=*) "Assertion failed"
!!!!!              STOP
!
!   We make a special case when we have so few values in
!   the high values set that it is bad performance to choose a pivot
!   and apply the general algorithm.
!
            Case (2)
               If (XHIGT(1) <= XHIGT(2)) Then
                  JLOW = JLOW + 1
                  XLOWT (JLOW) = XHIGT (1)
                  JLOW = JLOW + 1
                  XLOWT (JLOW) = XHIGT (2)
               Else
                  JLOW = JLOW + 1
                  XLOWT (JLOW) = XHIGT (2)
                  JLOW = JLOW + 1
                  XLOWT (JLOW) = XHIGT (1)
               End If
               Exit
!
            Case (3)
!
!
               XWRK1 = XHIGT (1)
               XWRK2 = XHIGT (2)
               XWRK3 = XHIGT (3)
               If (XWRK2 < XWRK1) Then
                  XHIGT (1) = XWRK2
                  XHIGT (2) = XWRK1
                  XWRK2 = XWRK1
               End If
               If (XWRK2 > XWRK3) Then
                  XHIGT (3) = XWRK2
                  XHIGT (2) = XWRK3
                  XWRK2 = XWRK3
                  If (XWRK2 < XHIGT(1)) Then
                     XHIGT (2) = XHIGT (1)
                     XHIGT (1) = XWRK2
                  End If
               End If
               JHIG = 0
               Do ICRS = JLOW + 1, INTH
                  JHIG = JHIG + 1
                  XLOWT (ICRS) = XHIGT (JHIG)
               End Do
               JLOW = INTH
               Exit
!
            Case (4:)
!
!
               XPIV0 = XPIV
               IFIN = JHIG
!
!  One chooses a pivot from the 2 first values and the last one.
!  This should ensure sufficient renewal between iterations to
!  avoid worst case behavior effects.
!
               XWRK1 = XHIGT (1)
               XWRK2 = XHIGT (2)
               XWRK3 = XHIGT (IFIN)
               If (XWRK2 < XWRK1) Then
                  XHIGT (1) = XWRK2
                  XHIGT (2) = XWRK1
                  XWRK2 = XWRK1
               End If
               If (XWRK2 > XWRK3) Then
                  XHIGT (IFIN) = XWRK2
                  XHIGT (2) = XWRK3
                  XWRK2 = XWRK3
                  If (XWRK2 < XHIGT(1)) Then
                     XHIGT (2) = XHIGT (1)
                     XHIGT (1) = XWRK2
                  End If
               End If
!
               XWRK1 = XHIGT (1)
               JLOW = JLOW + 1
               XLOWT (JLOW) = XWRK1
               XPIV = XWRK1 + 0.5 * (XHIGT(IFIN)-XWRK1)
!
!  One takes values <= pivot to XLOWT
!  Again, 2 parts, one where we take care of the remaining
!  high values because we might still need them, and the
!  other when we know that we will have more than enough
!  low values in the end.
!
               JHIG = 0
               Do ICRS = 2, IFIN
                  If (XHIGT(ICRS) <= XPIV) Then
                     JLOW = JLOW + 1
                     XLOWT (JLOW) = XHIGT (ICRS)
                     If (JLOW >= INTH) Exit
                  Else
                     JHIG = JHIG + 1
                     XHIGT (JHIG) = XHIGT (ICRS)
                  End If
               End Do
!
               Do ICRS = ICRS + 1, IFIN
                  If (XHIGT(ICRS) <= XPIV) Then
                     JLOW = JLOW + 1
                     XLOWT (JLOW) = XHIGT (ICRS)
                  End If
               End Do
            End Select
!
!
         Case (1)
!
!  Only 1 value is missing in low part
!
            XMIN = XHIGT(1)
            IHIG = 1
            Do ICRS = 2, JHIG
               If (XHIGT(ICRS) < XMIN) Then
                  XMIN = XHIGT(ICRS)
                  IHIG = ICRS
               End If
            End Do
!
            VALNTH = XHIGT (IHIG)
            Return
!
!
         Case (0)
!
!  Low part is exactly what we want
!
            Exit
!
!
         Case (-5:-1)
!
!  Only few values too many in low part
!
            XHIGT (1) = XLOWT (1)
            ILOW = 1 + INTH - JLOW
            Do ICRS = 2, INTH
               XWRK = XLOWT (ICRS)
               Do IDCR = ICRS - 1, MAX (1, ILOW), - 1
                  If (XWRK < XHIGT(IDCR)) Then
                     XHIGT (IDCR+1) = XHIGT (IDCR)
                  Else
                     Exit
                  End If
               End Do
               XHIGT (IDCR+1) = XWRK
               ILOW = ILOW + 1
            End Do
!
            XWRK1 = XHIGT(INTH)
            ILOW = 2*INTH - JLOW
            Do ICRS = INTH + 1, JLOW
               If (XLOWT (ICRS) < XWRK1) Then
                  XWRK = XLOWT (ICRS)
                  Do IDCR = INTH - 1, MAX (1, ILOW), - 1
                     If (XWRK >= XHIGT(IDCR)) Exit
                     XHIGT (IDCR+1) = XHIGT (IDCR)
                  End Do
                  XHIGT (IDCR+1) = XLOWT (ICRS)
                  XWRK1 = XHIGT(INTH)
               End If
               ILOW = ILOW + 1
            End Do
!
            VALNTH = XHIGT(INTH)
            Return
!
!
         Case (:-6)
!
! last case: too many values in low part
!

            IMIL = (JLOW+1) / 2
            IFIN = JLOW
!
!  One chooses a pivot from 1st, last, and middle values
!
            If (XLOWT(IMIL) < XLOWT(1)) Then
               XWRK = XLOWT (1)
               XLOWT (1) = XLOWT (IMIL)
               XLOWT (IMIL) = XWRK
            End If
            If (XLOWT(IMIL) > XLOWT(IFIN)) Then
               XWRK = XLOWT (IFIN)
               XLOWT (IFIN) = XLOWT (IMIL)
               XLOWT (IMIL) = XWRK
               If (XLOWT(IMIL) < XLOWT(1)) Then
                  XWRK = XLOWT (1)
                  XLOWT (1) = XLOWT (IMIL)
                  XLOWT (IMIL) = XWRK
               End If
            End If
            If (IFIN <= 3) Exit
!
            XPIV = XLOWT(1) + REAL(INTH)/REAL(JLOW+INTH) * &
                              (XLOWT(IFIN)-XLOWT(1))

!
!  One takes values > XPIV to XHIGT
!
            JHIG = 0
            JLOW = 0
!
            If (XLOWT(IFIN) > XPIV) Then
               ICRS = 0
               Do
                  ICRS = ICRS + 1
                  If (XLOWT(ICRS) > XPIV) Then
                     JHIG = JHIG + 1
                     XHIGT (JHIG) = XLOWT (ICRS)
                     If (ICRS >= IFIN) Exit
                  Else
                     JLOW = JLOW + 1
                     XLOWT (JLOW) = XLOWT (ICRS)
                     If (JLOW >= INTH) Exit
                  End If
               End Do
!
               If (ICRS < IFIN) Then
                  Do
                     ICRS = ICRS + 1
                     If (XLOWT(ICRS) <= XPIV) Then
                        JLOW = JLOW + 1
                        XLOWT (JLOW) = XLOWT (ICRS)
                     Else
                        If (ICRS >= IFIN) Exit
                     End If
                  End Do
               End If
            Else
               Do ICRS = 1, IFIN
                  If (XLOWT(ICRS) > XPIV) Then
                     JHIG = JHIG + 1
                     XHIGT (JHIG) = XLOWT (ICRS)
                  Else
                     JLOW = JLOW + 1
                     XLOWT (JLOW) = XLOWT (ICRS)
                     If (JLOW >= INTH) Exit
                  End If
               End Do
!
               Do ICRS = ICRS + 1, IFIN
                  If (XLOWT(ICRS) <= XPIV) Then
                     JLOW = JLOW + 1
                     XLOWT (JLOW) = XLOWT (ICRS)
                  End If
               End Do
            End If
!
         End Select
!
      End Do
!
!  Now, we only need to find maximum of the 1:INTH set
!
      VALNTH = MAXVAL (XLOWT (1:INTH))
      Return
!
!
End Function I_valnth
end module m_valnth