      Module Subroutines

      Use MQC_Algebra
      Use MQC_Gaussian

      Contains

!======================================================================================================
!
!     SUBROUTINE BIORTHOG
!
      Subroutine Biorthsub(IOut,IPrint,NBasis,NElectrons,Multiplicity,Overlap_Matrix, &
        MO_Coeff,Biorthog_Orbs,Biorthog_Overlap)
!
!     This subroutine performs biorthogonalization of
!     unrestricted orbitals
!
!     Variable Declarations...
!
      Implicit None
      Integer::IOut,NBasis,NElectrons,Multiplicity,NAlpha,NBeta,NOccA, &
        NOccB,NVirtA,NVirtB,ND,NSingA,NSingB,I,Ind,NVirtP,IPrint
      Real::Thresh=0.1d0
      Type(MQC_MO_Coefficients)::MO_Coeff,Biorthog_Orbs
      Real,Dimension(:),Allocatable::A_SVals,Biorthog_Overlap
      Real,Dimension(:,:),Intent(In)::Overlap_Matrix
      Real,Dimension(:,:),Allocatable::A_UVecs,A_VVecs, &
        MO_Overlap

      NAlpha = (NElectrons + (Multiplicity-1))/2
      NBeta = NElectrons-NAlpha
      NOccA = NAlpha
      NOccB = NBeta
      NVirtA = NBasis-NAlpha
      NVirtB = NBasis-NBeta
!
!     Allocate arrays in which to collect results
!
      Allocate(Biorthog_Overlap(NBasis))
      Call MQC_Gaussian_Fill_MO_Coefficients(NBasis,MO_Coeff%Alpha, &
        MO_Coeff%Beta,Biorthog_Orbs)
!
!     Do SVD on occupied alpha and beta orbitals and then rotate MO coefficients
!
      Write(*,*) 'Occupied Alpha - Occupied Beta'
      Allocate(MO_Overlap(NOccA,NOccB))
      MO_Overlap = MatMul(MatMul(Transpose(Biorthog_Orbs%Alpha(:,1:NOccA)),Overlap_Matrix), &
        Biorthog_Orbs%Beta(:,1:NOccB))
      If(IPrint.ge.1) Call Print_Matrix(IOut,MO_Overlap,' MO Overlap')
      Call MQC_Matrix_SVD(MO_Overlap,A_UVecs,A_VVecs,A_SVals)
      If(IPrint.ge.1) then
        Call Print_Matrix(IOut,A_UVecs,'U Vectors')
        Call Print_Matrix(IOut,A_VVecs,'V Vectors')
      EndIf
      Call Print_Vector(IOut,A_SVals,'Singular Values')
      Biorthog_Orbs%Alpha(:,1:NOccA) = MatMul(Biorthog_Orbs%Alpha(:,1:NOccA),A_UVecs)
      Biorthog_Orbs%Beta(:,1:NOccB) = MatMul(Biorthog_Orbs%Beta(:,1:NOccB),Transpose(A_VVecs))
      Biorthog_Overlap(1:Size(A_SVals,1)) = A_SVals
      If(IPrint.ge.1) then
        Call Print_Matrix(IOut,Biorthog_Orbs%Alpha(:,1:NOccA),'Biorthogonalized Alpha Orbitals')
        Call Print_Matrix(IOut,Biorthog_Orbs%Beta(:,1:NOccB),'Biorthogonalized Beta Orbitals')
      EndIf
      ND = 0
      Do I = 1, Min(NOccA,NOccB)
        If(A_SVals(I).ge.Thresh) ND = ND + 1
      EndDo
!     Gaussian code has this always set so we never have singly occupied beta
      ND = NBeta
      NSingA = NAlpha - ND
      NSingB = NBeta - ND
!
!     Do SVD on left-over alpha occupieds and beta virtals and then rotate MO coefficients
!
      If(NSingA.gt.0) then
        Write(*,*) 'Singly Occupied Alpha - Virtual Beta'
        Deallocate(MO_Overlap,A_SVals,A_VVecs,A_UVecs)
        Allocate(MO_Overlap(NSingA,NVirtB))
        MO_Overlap = MatMul(MatMul(Transpose(Biorthog_Orbs%Alpha(:,ND+1:ND+NSingA)),Overlap_Matrix), &
          Biorthog_Orbs%Beta(:,NOccB+1:NBasis))
        If(IPrint.ge.1) Call Print_Matrix(IOut,MO_Overlap,' MO Overlap')
        Call MQC_Matrix_SVD(MO_Overlap,A_UVecs,A_VVecs,A_SVals)
        If(IPrint.ge.1) then
          Call Print_Matrix(IOut,A_UVecs,'U Vectors')
          Call Print_Matrix(IOut,A_VVecs,'V Vectors')
        EndIf
        Call Print_Vector(IOut,A_SVals,'Singular Values')
        Biorthog_Orbs%Alpha(:,ND+1:ND+NSingA) = MatMul(Biorthog_Orbs%Alpha(:,ND+1:ND+NSingA),A_UVecs)
        Biorthog_Orbs%Beta(:,NOccB+1:NOccB+NVirtB) = MatMul(Biorthog_Orbs%Beta(:,NOccB+1:NOccB+NVirtB),Transpose(A_VVecs))
        Biorthog_Overlap(ND+1:ND+NSingA) = A_SVals
        If(IPrint.ge.1) then
          Call Print_Matrix(IOut,Biorthog_Orbs%Alpha(:,ND+1:ND+NSingA),'Biorthogonalized Alpha Orbitals')
          Call Print_Matrix(IOut,Biorthog_Orbs%Beta(:,NOccB+1:NOccB+NVirtB),'Biorthogonalized Beta Orbitals')
        EndIf
      EndIf
!
!     Do SVD on left-over beta occupieds and alpha virtals and then rotate MO coefficients
!
      If(NSingB.gt.0) then
        Write(*,*) 'Singly Occupied Beta - Virtual Alpha'
        Deallocate(MO_Overlap,A_SVals,A_VVecs,A_UVecs)
        Allocate(MO_Overlap(NVirtA,NSingB))
        MO_Overlap = MatMul(MatMul(Transpose(Biorthog_Orbs%Alpha(:,NOccA+1:NBasis)),Overlap_Matrix), &
          Biorthog_Orbs%Beta(:,ND+1:ND+NSingB))
        If(IPrint.ge.1) Call Print_Matrix(IOut,MO_Overlap,' MO Overlap')
        Call MQC_Matrix_SVD(MO_Overlap,A_UVecs,A_VVecs,A_SVals)
        If(IPrint.ge.1) then
          Call Print_Matrix(IOut,A_UVecs,'U Vectors')
          Call Print_Matrix(IOut,A_VVecs,'V Vectors')
        EndIf
        Call Print_Vector(IOut,A_SVals,'Singular Values')
        Biorthog_Orbs%Alpha(:,NOccA+1:NOccA+NVirtA) = MatMul(Biorthog_Orbs%Alpha(:,NOccA+1:NOccA+NVirtA),A_UVecs)
        Biorthog_Orbs%Beta(:,ND+1:ND+NSingB) = MatMul(Biorthog_Orbs%Beta(:,ND+1:ND+NSingB),Transpose(A_VVecs))
        Biorthog_Overlap(ND+NSingA+1:ND+NSingA+NSingB) = A_SVals
        If(IPrint.ge.1) then
          Call Print_Matrix(IOut,Biorthog_Orbs%Alpha(:,ND+1:ND+NSingA),'Biorthogonalized Alpha Orbitals')
          Call Print_Matrix(IOut,Biorthog_Orbs%Beta(:,NOccB+1:NOccB+NVirtB),'Biorthogonalized Beta Orbitals')
        EndIf
      EndIf
!
!     Do SVD on alpha and beta virtal orbitals and then rotate MO coefficients
!
      Ind = ND + NSingA + NSingB
      NVirtP = NBasis - Ind
      If(NVirtP.gt.0) then
        Write(*,*) 'Virtual Alpha - Virtual Beta'
        Deallocate(MO_Overlap,A_SVals,A_VVecs,A_UVecs)
        Allocate(MO_Overlap(NVirtP,NVirtP))
        MO_Overlap = MatMul(MatMul(Transpose(Biorthog_Orbs%Alpha(:,Ind+1:Ind+NVirtP)),Overlap_Matrix), &
          Biorthog_Orbs%Beta(:,Ind+1:Ind+NVirtP))
        If(IPrint.ge.1) Call Print_Matrix(IOut,MO_Overlap,' MO Overlap')
        Call MQC_Matrix_SVD(MO_Overlap,A_UVecs,A_VVecs,A_SVals)
        If(IPrint.ge.1) then
          Call Print_Matrix(IOut,A_UVecs,'U Vectors')
          Call Print_Matrix(IOut,A_VVecs,'V Vectors')
        EndIf
        Call Print_Vector(IOut,A_SVals,'Singular Values')
        Biorthog_Orbs%Alpha(:,NOccA+1:NOccA+NVirtA) = MatMul(Biorthog_Orbs%Alpha(:,Ind+1:Ind+NVirtP),A_UVecs)
        Biorthog_Orbs%Beta(:,Ind+1:Ind+NVirtP) = MatMul(Biorthog_Orbs%Beta(:,Ind+1:Ind+NVirtP),Transpose(A_VVecs))
        Biorthog_Overlap(Ind+1:Ind+NVirtP) = A_SVals
        If(IPrint.ge.1) then
          Call Print_Matrix(IOut,Biorthog_Orbs%Alpha(:,Ind+1:Ind+NVirtP),'Biorthogonalized Alpha Orbitals')
          Call Print_Matrix(IOut,Biorthog_Orbs%Beta(:,Ind+1:Ind+NVirtP),'Biorthogonalized Beta Orbitals')
        EndIf
      EndIf
!
      If(IPrint.ge.1) then
        Call Print_Matrix(IOut,Biorthog_Orbs%Alpha,'Biorthogonalized Alpha Orbitals')
        Call Print_Matrix(IOut,Biorthog_Orbs%Beta,'Biorthogonalized Beta Orbitals')
        Call Print_Vector(IOut,Biorthog_Overlap,'Biorthogonal Overlap')
      EndIf
      Deallocate(MO_Overlap,A_SVals,A_VVecs,A_UVecs)
!
 999  End Subroutine Biorthsub
!
!======================================================================================================
!
      End Module Subroutines


      subroutine regrid(iopt,mx,x,my,y,z,xb,xe,yb,ye,kx,ky,s,
     * nxest,nyest,nx,tx,ny,ty,c,fp,wrk,lwrk,iwrk,kwrk,ier)
c given the set of values z(i,j) on the rectangular grid (x(i),y(j)),
c i=1,...,mx;j=1,...,my, subroutine regrid determines a smooth bivar-
c iate spline approximation s(x,y) of degrees kx and ky on the rect-
c angle xb <= x <= xe, yb <= y <= ye.
c if iopt = -1 regrid calculates the least-squares spline according
c to a given set of knots.
c if iopt >= 0 the total numbers nx and ny of these knots and their
c position tx(j),j=1,...,nx and ty(j),j=1,...,ny are chosen automatic-
c ally by the routine. the smoothness of s(x,y) is then achieved by
c minimalizing the discontinuity jumps in the derivatives of s(x,y)
c across the boundaries of the subpanels (tx(i),tx(i+1))*(ty(j),ty(j+1).
c the amounth of smoothness is determined by the condition that f(p) =
c sum ((z(i,j)-s(x(i),y(j))))**2) be <= s, with s a given non-negative
c constant, called the smoothing factor.
c the fit is given in the b-spline representation (b-spline coefficients
c c((ny-ky-1)*(i-1)+j),i=1,...,nx-kx-1;j=1,...,ny-ky-1) and can be eval-
c uated by means of subroutine bispev.
c
c calling sequence:
c     call regrid(iopt,mx,x,my,y,z,xb,xe,yb,ye,kx,ky,s,nxest,nyest,
c    *  nx,tx,ny,ty,c,fp,wrk,lwrk,iwrk,kwrk,ier)
c
c parameters:
c  iopt  : integer flag. on entry iopt must specify whether a least-
c          squares spline (iopt=-1) or a smoothing spline (iopt=0 or 1)
c          must be determined.
c          if iopt=0 the routine will start with an initial set of knots
c          tx(i)=xb,tx(i+kx+1)=xe,i=1,...,kx+1;ty(i)=yb,ty(i+ky+1)=ye,i=
c          1,...,ky+1. if iopt=1 the routine will continue with the set
c          of knots found at the last call of the routine.
c          attention: a call with iopt=1 must always be immediately pre-
c                     ceded by another call with iopt=1 or iopt=0 and
c                     s.ne.0.
c          unchanged on exit.
c  mx    : integer. on entry mx must specify the number of grid points
c          along the x-axis. mx > kx . unchanged on exit.
c  x     : real array of dimension at least (mx). before entry, x(i)
c          must be set to the x-co-ordinate of the i-th grid point
c          along the x-axis, for i=1,2,...,mx. these values must be
c          supplied in strictly ascending order. unchanged on exit.
c  my    : integer. on entry my must specify the number of grid points
c          along the y-axis. my > ky . unchanged on exit.
c  y     : real array of dimension at least (my). before entry, y(j)
c          must be set to the y-co-ordinate of the j-th grid point
c          along the y-axis, for j=1,2,...,my. these values must be
c          supplied in strictly ascending order. unchanged on exit.
c  z     : real array of dimension at least (mx*my).
c          before entry, z(my*(i-1)+j) must be set to the data value at
c          the grid point (x(i),y(j)) for i=1,...,mx and j=1,...,my.
c          unchanged on exit.
c  xb,xe : real values. on entry xb,xe,yb and ye must specify the bound-
c  yb,ye   aries of the rectangular approximation domain.
c          xb<=x(i)<=xe,i=1,...,mx; yb<=y(j)<=ye,j=1,...,my.
c          unchanged on exit.
c  kx,ky : integer values. on entry kx and ky must specify the degrees
c          of the spline. 1<=kx,ky<=5. it is recommended to use bicubic
c          (kx=ky=3) splines. 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  nxest : integer. unchanged on exit.
c  nyest : integer. unchanged on exit.
c          on entry, nxest and nyest must specify an upper bound for the
c          number of knots required in the x- and y-directions respect.
c          these numbers will also determine the storage space needed by
c          the routine. nxest >= 2*(kx+1), nyest >= 2*(ky+1).
c          in most practical situation nxest = mx/2, nyest=my/2, will
c          be sufficient. always large enough are nxest=mx+kx+1, nyest=
c          my+ky+1, the number of knots needed for interpolation (s=0).
c          see also further comments.
c  nx    : integer.
c          unless ier=10 (in case iopt >=0), nx will contain the total
c          number of knots with respect to the x-variable, of the spline
c          approximation returned. if the computation mode iopt=1 is
c          used, the value of nx should be left unchanged between sub-
c          sequent calls.
c          in case iopt=-1, the value of nx should be specified on entry
c  tx    : real array of dimension nmax.
c          on succesful exit, this array will contain the knots of the
c          spline with respect to the x-variable, i.e. the position of
c          the interior knots tx(kx+2),...,tx(nx-kx-1) as well as the
c          position of the additional knots tx(1)=...=tx(kx+1)=xb and
c          tx(nx-kx)=...=tx(nx)=xe needed for the b-spline representat.
c          if the computation mode iopt=1 is used, the values of tx(1),
c          ...,tx(nx) should be left unchanged between subsequent calls.
c          if the computation mode iopt=-1 is used, the values tx(kx+2),
c          ...tx(nx-kx-1) must be supplied by the user, before entry.
c          see also the restrictions (ier=10).
c  ny    : integer.
c          unless ier=10 (in case iopt >=0), ny will contain the total
c          number of knots with respect to the y-variable, of the spline
c          approximation returned. if the computation mode iopt=1 is
c          used, the value of ny should be left unchanged between sub-
c          sequent calls.
c          in case iopt=-1, the value of ny should be specified on entry
c  ty    : real array of dimension nmax.
c          on succesful exit, this array will contain the knots of the
c          spline with respect to the y-variable, i.e. the position of
c          the interior knots ty(ky+2),...,ty(ny-ky-1) as well as the
c          position of the additional knots ty(1)=...=ty(ky+1)=yb and
c          ty(ny-ky)=...=ty(ny)=ye needed for the b-spline representat.
c          if the computation mode iopt=1 is used, the values of ty(1),
c          ...,ty(ny) should be left unchanged between subsequent calls.
c          if the computation mode iopt=-1 is used, the values ty(ky+2),
c          ...ty(ny-ky-1) must be supplied by the user, before entry.
c          see also the restrictions (ier=10).
c  c     : real array of dimension at least (nxest-kx-1)*(nyest-ky-1).
c          on succesful exit, c contains the coefficients of the spline
c          approximation s(x,y)
c  fp    : real. unless ier=10, fp contains the sum of squared
c          residuals of the spline approximation returned.
c  wrk   : real array of dimension (lwrk). used as workspace.
c          if the computation mode iopt=1 is used the values of wrk(1),
c          ...,wrk(4) should be left unchanged 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.
c          lwrk must not be too small.
c           lwrk >= 4+nxest*(my+2*kx+5)+nyest*(2*ky+5)+mx*(kx+1)+
c            my*(ky+1) +u
c           where u is the larger of my and nxest.
c  iwrk  : integer array of dimension (kwrk). used as workspace.
c          if the computation mode iopt=1 is used the values of iwrk(1),
c          ...,iwrk(3) should be left unchanged between subsequent calls
c  kwrk  : integer. on entry kwrk must specify the actual dimension of
c          the array iwrk as declared in the calling (sub)program.
c          kwrk >= 3+mx+my+nxest+nyest.
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 spline 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 spline returned is an interpolating
c            spline (fp=0).
c   ier=-2 : normal return. the spline returned is the least-squares
c            polynomial of degrees kx and ky. in this extreme case fp
c            gives the upper bound for the smoothing factor s.
c   ier=1  : error. the required storage space exceeds the available
c            storage space, as specified by the parameters nxest and
c            nyest.
c            probably causes : nxest or nyest too small. if these param-
c            eters are already large, it may also indicate that s is
c            too small
c            the approximation returned is the least-squares spline
c            according to the current set of knots. the parameter fp
c            gives the corresponding sum of squared residuals (fp>s).
c   ier=2  : error. a theoretically impossible result was found during
c            the iteration proces for finding a smoothing spline with
c            fp = s. probably causes : s too small.
c            there is an approximation returned but the corresponding
c            sum of squared residuals does not satisfy the condition
c            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 spline
c            with fp=s has been reached. probably causes : s too small
c            there is an approximation returned but the corresponding
c            sum of squared residuals does not satisfy the condition
c            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, 1<=kx,ky<=5, mx>kx, my>ky, nxest>=2*kx+2,
c            nyest>=2*ky+2, kwrk>=3+mx+my+nxest+nyest,
c            lwrk >= 4+nxest*(my+2*kx+5)+nyest*(2*ky+5)+mx*(kx+1)+
c             my*(ky+1) +max(my,nxest),
c            xb<=x(i-1)<x(i)<=xe,i=2,..,mx,yb<=y(j-1)<y(j)<=ye,j=2,..,my
c            if iopt=-1: 2*kx+2<=nx<=min(nxest,mx+kx+1)
c                        xb<tx(kx+2)<tx(kx+3)<...<tx(nx-kx-1)<xe
c                        2*ky+2<=ny<=min(nyest,my+ky+1)
c                        yb<ty(ky+2)<ty(ky+3)<...<ty(ny-ky-1)<ye
c                    the schoenberg-whitney conditions, i.e. there must
c                    be subset of grid co-ordinates xx(p) and yy(q) such
c                    that   tx(p) < xx(p) < tx(p+kx+1) ,p=1,...,nx-kx-1
c                           ty(q) < yy(q) < ty(q+ky+1) ,q=1,...,ny-ky-1
c            if iopt>=0: s>=0
c                        if s=0 : nxest>=mx+kx+1, nyest>=my+ky+1
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   regrid does not allow individual weighting of the data-values.
c   so, if these were determined to widely different accuracies, then
c   perhaps the general data set routine surfit should rather be used
c   in spite of efficiency.
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 spline will be too smooth and signal will be
c   lost ; if s is too small the spline will pick up too much noise. in
c   the extreme cases the program will return an interpolating spline if
c   s=0 and the least-squares polynomial (degrees kx,ky) 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 accuracy of the data values.
c   if the user has an idea of the statistical errors on the data, he
c   can also find a proper estimate for s. for, by assuming that, if he
c   specifies the right s, regrid will return a spline s(x,y) which
c   exactly reproduces the function underlying the data he can evaluate
c   the sum((z(i,j)-s(x(i),y(j)))**2) to find a good estimate for this s
c   for example, if he knows that the statistical errors on his z(i,j)-
c   values is not greater than 0.1, he may expect that a good s should
c   have a value not larger than mx*my*(0.1)**2.
c   if nothing is known about the statistical error in z(i,j), s must
c   be determined by trial and error, taking account of the comments
c   above. the best is then to start with a very large value of s (to
c   determine the least-squares polynomial and the corresponding upper
c   bound fp0 for s) and then to progressively decrease the value of s
c   ( say by a factor 10 in the beginning, i.e. s=fp0/10,fp0/100,...
c   and more carefully as the approximation shows more detail) to
c   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 regrid 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   function underlying the data. if the computation mode iopt=1
c   is used, the knots returned may also depend on the s-values at
c   previous calls (if these were smaller). therefore, if after a number
c   of 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   regrid once more with the selected value for s but now with iopt=0.
c   indeed, regrid 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   the number of knots may also depend on the upper bounds nxest and
c   nyest. indeed, if at a certain stage in regrid the number of knots
c   in one direction (say nx) has reached the value of its upper bound
c   (nxest), then from that moment on all subsequent knots are added
c   in the other (y) direction. this may indicate that the value of
c   nxest is too small. on the other hand, it gives the user the option
c   of limiting the number of knots the routine locates in any direction
c   for example, by setting nxest=2*kx+2 (the lowest allowable value for
c   nxest), the user can indicate that he wants an approximation which
c   is a simple polynomial of degree kx in the variable x.
c
c  other subroutines required:
c    fpback,fpbspl,fpregr,fpdisc,fpgivs,fpgrre,fprati,fprota,fpchec,
c    fpknot
c
c  references:
c   dierckx p. : a fast algorithm for smoothing data on a rectangular
c                grid while using spline functions, siam j.numer.anal.
c                19 (1982) 1286-1304.
c   dierckx p. : a fast algorithm for smoothing data on a rectangular
c                grid while using spline functions, report tw53, dept.
c                computer science,k.u.leuven, 1980.
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 1989
c
c  ..
c  ..scalar arguments..
      real*8 xb,xe,yb,ye,s,fp
      integer iopt,mx,my,kx,ky,nxest,nyest,nx,ny,lwrk,kwrk,ier
c  ..array arguments..
      real*8 x(mx),y(my),z(mx*my),tx(nxest),ty(nyest),
     * c((nxest-kx-1)*(nyest-ky-1)),wrk(lwrk)
      integer iwrk(kwrk)
c  ..local scalars..
      real*8 tol
      integer i,j,jwrk,kndx,kndy,knrx,knry,kwest,kx1,kx2,ky1,ky2,
     * lfpx,lfpy,lwest,lww,maxit,nc,nminx,nminy,mz
c  ..function references..
      integer max0
c  ..subroutine references..
c    fpregr,fpchec
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(kx.le.0 .or. kx.gt.5) go to 70
      kx1 = kx+1
      kx2 = kx1+1
      if(ky.le.0 .or. ky.gt.5) go to 70
      ky1 = ky+1
      ky2 = ky1+1
      if(iopt.lt.(-1) .or. iopt.gt.1) go to 70
      nminx = 2*kx1
      if(mx.lt.kx1 .or. nxest.lt.nminx) go to 70
      nminy = 2*ky1
      if(my.lt.ky1 .or. nyest.lt.nminy) go to 70
      mz = mx*my
      nc = (nxest-kx1)*(nyest-ky1)
      lwest = 4+nxest*(my+2*kx2+1)+nyest*(2*ky2+1)+mx*kx1+
     * my*ky1+max0(nxest,my)
      kwest = 3+mx+my+nxest+nyest
      if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 70
      if(xb.gt.x(1) .or. xe.lt.x(mx)) go to 70
      do 10 i=2,mx
        if(x(i-1).ge.x(i)) go to 70
  10  continue
      if(yb.gt.y(1) .or. ye.lt.y(my)) go to 70
      do 20 i=2,my
        if(y(i-1).ge.y(i)) go to 70
  20  continue
      if(iopt.ge.0) go to 50
      if(nx.lt.nminx .or. nx.gt.nxest) go to 70
      j = nx
      do 30 i=1,kx1
        tx(i) = xb
        tx(j) = xe
        j = j-1
  30  continue
      call fpchec(x,mx,tx,nx,kx,ier)
      if(ier.ne.0) go to 70
      if(ny.lt.nminy .or. ny.gt.nyest) go to 70
      j = ny
      do 40 i=1,ky1
        ty(i) = yb
        ty(j) = ye
        j = j-1
  40  continue
      call fpchec(y,my,ty,ny,ky,ier)
      if (ier.eq.0) go to 60
      go to 70
  50  if(s.lt.0.) go to 70
      if(s.eq.0. .and. (nxest.lt.(mx+kx1) .or. nyest.lt.(my+ky1)) )
     * go to 70
      ier = 0
c  we partition the working space and determine the spline approximation
  60  lfpx = 5
      lfpy = lfpx+nxest
      lww = lfpy+nyest
      jwrk = lwrk-4-nxest-nyest
      knrx = 4
      knry = knrx+mx
      kndx = knry+my
      kndy = kndx+nxest
      call fpregr(iopt,x,mx,y,my,z,mz,xb,xe,yb,ye,kx,ky,s,nxest,nyest,
     * tol,maxit,nc,nx,tx,ny,ty,c,fp,wrk(1),wrk(2),wrk(3),wrk(4),
     * wrk(lfpx),wrk(lfpy),iwrk(1),iwrk(2),iwrk(3),iwrk(knrx),
     * iwrk(knry),iwrk(kndx),iwrk(kndy),wrk(lww),jwrk,ier)
  70  return
      end


      SUBROUTINE IB01BD( METH, JOB, JOBCK, NOBR, N, M, L, NSMPL, R,
     $                   LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ,
     $                   RY, LDRY, S, LDS, K, LDK, TOL, IWORK, DWORK,
     $                   LDWORK, BWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To estimate the system matrices A, C, B, and D, the noise
C     covariance matrices Q, Ry, and S, and the Kalman gain matrix K
C     of a linear time-invariant state space model, using the
C     processed triangular factor R of the concatenated block Hankel
C     matrices, provided by SLICOT Library routine IB01AD.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     METH    CHARACTER*1
C             Specifies the subspace identification method to be used,
C             as follows:
C             = 'M':  MOESP  algorithm with past inputs and outputs;
C             = 'N':  N4SID  algorithm;
C             = 'C':  combined method:  MOESP  algorithm for finding the
C                     matrices A and C, and  N4SID  algorithm for
C                     finding the matrices B and D.
C
C     JOB     CHARACTER*1
C             Specifies which matrices should be computed, as follows:
C             = 'A':  compute all system matrices, A, B, C, and D;
C             = 'C':  compute the matrices A and C only;
C             = 'B':  compute the matrix B only;
C             = 'D':  compute the matrices B and D only.
C
C     JOBCK   CHARACTER*1
C             Specifies whether or not the covariance matrices and the
C             Kalman gain matrix are to be computed, as follows:
C             = 'C':  the covariance matrices only should be computed;
C             = 'K':  the covariance matrices and the Kalman gain
C                     matrix should be computed;
C             = 'N':  the covariance matrices and the Kalman gain matrix
C                     should not be computed.
C
C     Input/Output Parameters
C
C     NOBR    (input) INTEGER
C             The number of block rows,  s,  in the input and output
C             Hankel matrices processed by other routines.  NOBR > 1.
C
C     N       (input) INTEGER
C             The order of the system.  NOBR > N > 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     L       (input) INTEGER
C             The number of system outputs.  L > 0.
C
C     NSMPL   (input) INTEGER
C             If  JOBCK = 'C' or 'K',  the total number of samples used
C             for calculating the covariance matrices.
C             NSMPL >= 2*(M+L)*NOBR.
C             This parameter is not meaningful if  JOBCK = 'N'.
C
C     R       (input/workspace) DOUBLE PRECISION array, dimension
C             ( LDR,2*(M+L)*NOBR )
C             On entry, the leading  2*(M+L)*NOBR-by-2*(M+L)*NOBR  part
C             of this array must contain the relevant data for the MOESP
C             or N4SID algorithms, as constructed by SLICOT Library
C             routine IB01AD. Let  R_ij,  i,j = 1:4,  be the
C             ij submatrix of  R  (denoted  S  in IB01AD),  partitioned
C             by  M*NOBR,  L*NOBR,  M*NOBR,  and  L*NOBR  rows and
C             columns. The submatrix  R_22  contains the matrix of left
C             singular vectors used. Also needed, for  METH = 'N'  or
C             JOBCK <> 'N',  are the submatrices  R_11,  R_14 : R_44,
C             and, for  METH = 'M' or 'C'  and  JOB <> 'C', the
C             submatrices  R_31  and  R_12,  containing the processed
C             matrices  R_1c  and  R_2c,  respectively, as returned by
C             SLICOT Library routine IB01AD.
C             Moreover, if  METH = 'N'  and  JOB = 'A' or 'C',  the
C             block-row  R_41 : R_43  must contain the transpose of the
C             block-column  R_14 : R_34  as returned by SLICOT Library
C             routine IB01AD.
C             The remaining part of  R  is used as workspace.
C             On exit, part of this array is overwritten. Specifically,
C             if  METH = 'M',  R_22  and  R_31  are overwritten if
C                 JOB = 'B' or 'D',  and  R_12,  R_22,  R_14 : R_34,
C                 and possibly  R_11  are overwritten if  JOBCK <> 'N';
C             if  METH = 'N',  all needed submatrices are overwritten.
C             The details of the contents of  R  need not be known if
C             this routine is called once just after calling the SLICOT
C             Library routine IB01AD.
C
C     LDR     INTEGER
C             The leading dimension of the array  R.
C             LDR >= 2*(M+L)*NOBR.
C
C     A       (input or output) DOUBLE PRECISION array, dimension
C             (LDA,N)
C             On entry, if  METH = 'N' or 'C'  and  JOB = 'B' or 'D',
C             the leading N-by-N part of this array must contain the
C             system state matrix.
C             If  METH = 'M'  or  (METH = 'N' or 'C'  and JOB = 'A'
C             or 'C'),  this array need not be set on input.
C             On exit, if  JOB = 'A' or 'C'  and  INFO = 0,  the
C             leading N-by-N part of this array contains the system
C             state matrix.
C
C     LDA     INTEGER
C             The leading dimension of the array A.
C             LDA >= N,  if  JOB = 'A' or 'C',  or  METH = 'N' or 'C'
C                            and  JOB = 'B' or 'D';
C             LDA >= 1,  otherwise.
C
C     C       (input or output) DOUBLE PRECISION array, dimension
C             (LDC,N)
C             On entry, if  METH = 'N' or 'C'  and  JOB = 'B' or 'D',
C             the leading L-by-N part of this array must contain the
C             system output matrix.
C             If  METH = 'M'  or  (METH = 'N' or 'C'  and JOB = 'A'
C             or 'C'),  this array need not be set on input.
C             On exit, if  JOB = 'A' or 'C'  and  INFO = 0,  or
C             INFO = 3  (or  INFO >= 0,  for  METH = 'M'),  the leading
C             L-by-N part of this array contains the system output
C             matrix.
C
C     LDC     INTEGER
C             The leading dimension of the array C.
C             LDC >= L,  if  JOB = 'A' or 'C',  or  METH = 'N' or 'C'
C                            and  JOB = 'B' or 'D';
C             LDC >= 1,  otherwise.
C
C     B       (output) DOUBLE PRECISION array, dimension (LDB,M)
C             If  M > 0,  JOB = 'A', 'B', or 'D'  and  INFO = 0,  the
C             leading N-by-M part of this array contains the system
C             input matrix. If  M = 0  or  JOB = 'C',  this array is
C             not referenced.
C
C     LDB     INTEGER
C             The leading dimension of the array B.
C             LDB >= N,  if M > 0 and JOB = 'A', 'B', or 'D';
C             LDB >= 1,  if M = 0 or  JOB = 'C'.
C
C     D       (output) DOUBLE PRECISION array, dimension (LDD,M)
C             If  M > 0,  JOB = 'A' or 'D'  and  INFO = 0,  the leading
C             L-by-M part of this array contains the system input-output
C             matrix. If  M = 0  or  JOB = 'C' or 'B',  this array is
C             not referenced.
C
C     LDD     INTEGER
C             The leading dimension of the array D.
C             LDD >= L,  if M > 0 and JOB = 'A' or 'D';
C             LDD >= 1,  if M = 0 or  JOB = 'C' or 'B'.
C
C     Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
C             If  JOBCK = 'C' or 'K',  the leading N-by-N part of this
C             array contains the positive semidefinite state covariance
C             matrix. If  JOBCK = 'K',  this matrix has been used as
C             state weighting matrix for computing the Kalman gain.
C             This parameter is not referenced if JOBCK = 'N'.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.
C             LDQ >= N,  if JOBCK = 'C' or 'K';
C             LDQ >= 1,  if JOBCK = 'N'.
C
C     RY      (output) DOUBLE PRECISION array, dimension (LDRY,L)
C             If  JOBCK = 'C' or 'K',  the leading L-by-L part of this
C             array contains the positive (semi)definite output
C             covariance matrix. If  JOBCK = 'K',  this matrix has been
C             used as output weighting matrix for computing the Kalman
C             gain.
C             This parameter is not referenced if JOBCK = 'N'.
C
C     LDRY    INTEGER
C             The leading dimension of the array RY.
C             LDRY >= L,  if JOBCK = 'C' or 'K';
C             LDRY >= 1,  if JOBCK = 'N'.
C
C     S       (output) DOUBLE PRECISION array, dimension (LDS,L)
C             If  JOBCK = 'C' or 'K',  the leading N-by-L part of this
C             array contains the state-output cross-covariance matrix.
C             If  JOBCK = 'K',  this matrix has been used as state-
C             output weighting matrix for computing the Kalman gain.
C             This parameter is not referenced if JOBCK = 'N'.
C
C     LDS     INTEGER
C             The leading dimension of the array S.
C             LDS >= N,  if JOBCK = 'C' or 'K';
C             LDS >= 1,  if JOBCK = 'N'.
C
C     K       (output) DOUBLE PRECISION array, dimension ( LDK,L )
C             If  JOBCK = 'K',  the leading  N-by-L  part of this array
C             contains the estimated Kalman gain matrix.
C             If  JOBCK = 'C' or 'N',  this array is not referenced.
C
C     LDK     INTEGER
C             The leading dimension of the array  K.
C             LDK >= N,  if JOBCK = 'K';
C             LDK >= 1,  if JOBCK = 'C' or 'N'.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used for estimating the rank of
C             matrices. If the user sets  TOL > 0,  then the given value
C             of  TOL  is used as a lower bound for the reciprocal
C             condition number;  an m-by-n matrix whose estimated
C             condition number is less than  1/TOL  is considered to
C             be of full rank.  If the user sets  TOL <= 0,  then an
C             implicitly computed, default tolerance, defined by
C             TOLDEF = m*n*EPS,  is used instead, where  EPS  is the
C             relative machine precision (see LAPACK Library routine
C             DLAMCH).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             LIWORK >= max(LIW1,LIW2), where
C             LIW1 = N,                     if METH <> 'N' and M = 0
C                                        or JOB = 'C' and JOBCK = 'N';
C             LIW1 = M*NOBR+N,              if METH <> 'N', JOB = 'C',
C                                           and JOBCK <> 'N';
C             LIW1 = max(L*NOBR,M*NOBR),    if METH = 'M', JOB <> 'C',
C                                           and JOBCK = 'N';
C             LIW1 = max(L*NOBR,M*NOBR+N),  if METH = 'M', JOB <> 'C',
C                                           and JOBCK = 'C' or 'K';
C             LIW1 = max(M*NOBR+N,M*(N+L)), if METH = 'N', or METH = 'C'
C                                           and JOB  <> 'C';
C             LIW2 = 0,                     if JOBCK <> 'K';
C             LIW2 = N*N,                   if JOBCK =  'K'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if  INFO = 0,  DWORK(1) returns the optimal value
C             of LDWORK,  and  DWORK(2),  DWORK(3),  DWORK(4),  and
C             DWORK(5)  contain the reciprocal condition numbers of the
C             triangular factors of the following matrices (defined in
C             SLICOT Library routine IB01PD and in the lower level
C             routines):
C                GaL  (GaL = Un(1:(s-1)*L,1:n)),
C                R_1c (if  METH = 'M' or 'C'),
C                M    (if  JOBCK = 'C' or 'K'  or  METH = 'N'),  and
C                Q or T  (see SLICOT Library routine IB01PY or IB01PX),
C             respectively.
C             If  METH = 'N',  DWORK(3)  is set to one without any
C             calculations. Similarly, if  METH = 'M'  and  JOBCK = 'N',
C             DWORK(4)  is set to one. If  M = 0  or  JOB = 'C',
C             DWORK(3)  and  DWORK(5)  are set to one.
C             If  JOBCK = 'K'  and  INFO = 0,  DWORK(6)  to  DWORK(13)
C             contain information about the accuracy of the results when
C             computing the Kalman gain matrix, as follows:
C                DWORK(6)  - reciprocal condition number of the matrix
C                            U11  of the Nth order system of algebraic
C                            equations from which the solution matrix  X
C                            of the Riccati equation is obtained;
C                DWORK(7)  - reciprocal pivot growth factor for the LU
C                            factorization of the matrix  U11;
C                DWORK(8)  - reciprocal condition number of the matrix
C                            As = A - S*inv(Ry)*C,  which is inverted by
C                            the standard Riccati solver;
C                DWORK(9)  - reciprocal pivot growth factor for the LU
C                            factorization of the matrix  As;
C                DWORK(10) - reciprocal condition number of the matrix
C                            Ry;
C                DWORK(11) - reciprocal condition number of the matrix
C                            Ry + C*X*C';
C                DWORK(12) - reciprocal condition number for the Riccati
C                            equation solution;
C                DWORK(13) - forward error bound for the Riccati
C                            equation solution.
C             On exit, if  INFO = -30,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= max( LDW1,LDW2,LDW3 ), where, if METH = 'M',
C             LDW1 >= max( 2*(L*NOBR-L)*N+2*N, (L*NOBR-L)*N+N*N+7*N ),
C                     if JOB = 'C' or JOB = 'A' and M = 0;
C             LDW1 >= max( 2*(L*NOBR-L)*N+N*N+7*N,
C                          (L*NOBR-L)*N+N+6*M*NOBR, (L*NOBR-L)*N+N+
C                          max( L+M*NOBR, L*NOBR +
C                                         max( 3*L*NOBR+1, M ) ) ),
C                     if M > 0 and JOB = 'A', 'B', or 'D';
C             LDW2 >= 0,                          if JOBCK = 'N';
C             LDW2 >= L*NOBR*N+
C                     max( (L*NOBR-L)*N+Aw+2*N+max(5*N,(2*M+L)*NOBR+L),
C                          4*(M*NOBR+N)+1, M*NOBR+2*N+L ),
C                                                 if JOBCK = 'C' or 'K',
C             where Aw = N+N*N, if M = 0 or JOB = 'C';
C                   Aw = 0,     otherwise;
C             if METH = 'N',
C             LDW1 >= L*NOBR*N+max( (L*NOBR-L)*N+2*N+(2*M+L)*NOBR+L,
C                                   2*(L*NOBR-L)*N+N*N+8*N,
C                                   N+4*(M*NOBR+N)+1, M*NOBR+3*N+L );
C             LDW2 >= 0, if M = 0 or JOB = 'C';
C             LDW2 >= L*NOBR*N+M*NOBR*(N+L)*(M*(N+L)+1)+
C                                max( (N+L)**2, 4*M*(N+L)+1 ),
C                     if M > 0 and JOB = 'A', 'B', or 'D';
C             and, if METH = 'C', LDW1 as
C             max( LDW1 for METH = 'M', JOB = 'C', LDW1 for METH = 'N'),
C             and LDW2 for METH = 'N' are used;
C             LDW3 >= 0,                     if JOBCK <> 'K';
C             LDW3 >= max(  4*N*N+2*N*L+L*L+max( 3*L,N*L ),
C                          14*N*N+12*N+5 ),  if JOBCK =  'K'.
C             For good performance,  LDWORK  should be larger.
C
C     BWORK   LOGICAL array, dimension (LBWORK)
C             LBWORK = 2*N, if JOBCK =  'K';
C             LBWORK = 0,   if JOBCK <> 'K'.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 4:  a least squares problem to be solved has a
C                   rank-deficient coefficient matrix;
C             = 5:  the computed covariance matrices are too small.
C                   The problem seems to be a deterministic one; the
C                   gain matrix is set to zero.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 2:  the singular value decomposition (SVD) algorithm did
C                   not converge;
C             = 3:  a singular upper triangular matrix was found;
C             = 3+i:  if  JOBCK = 'K'  and the associated Riccati
C                   equation could not be solved, where i = 1,...,6;
C                   (see the description of the parameter INFO for the
C                   SLICOT Library routine SB02RD for the meaning of
C                   the i values);
C             = 10: the QR algorithm did not converge.
C
C     METHOD
C
C     In the MOESP approach, the matrices  A  and  C  are first
C     computed from an estimated extended observability matrix [1],
C     and then, the matrices  B  and  D  are obtained by solving an
C     extended linear system in a least squares sense.
C     In the N4SID approach, besides the estimated extended
C     observability matrix, the solutions of two least squares problems
C     are used to build another least squares problem, whose solution
C     is needed to compute the system matrices  A,  C,  B,  and  D.  The
C     solutions of the two least squares problems are also optionally
C     used by both approaches to find the covariance matrices.
C     The Kalman gain matrix is obtained by solving a discrete-time
C     algebraic Riccati equation.
C
C     REFERENCES
C
C     [1] Verhaegen M., and Dewilde, P.
C         Subspace Model Identification. Part 1: The output-error
C         state-space model identification class of algorithms.
C         Int. J. Control, 56, pp. 1187-1210, 1992.
C
C     [2] Van Overschee, P., and De Moor, B.
C         N4SID: Two Subspace Algorithms for the Identification
C         of Combined Deterministic-Stochastic Systems.
C         Automatica, Vol.30, No.1, pp. 75-93, 1994.
C
C     [3] Van Overschee, P.
C         Subspace Identification : Theory - Implementation -
C         Applications.
C         Ph. D. Thesis, Department of Electrical Engineering,
C         Katholieke Universiteit Leuven, Belgium, Feb. 1995.
C
C     [4] Sima, V.
C         Subspace-based Algorithms for Multivariable System
C         Identification.
C         Studies in Informatics and Control, 5, pp. 335-344, 1996.
C
C     NUMERICAL ASPECTS
C
C     The implemented method consists in numerically stable steps.
C
C     FURTHER COMMENTS
C
C     The covariance matrices are computed using the N4SID approach.
C     Therefore, for efficiency reasons, it is advisable to set
C     METH = 'N',  if the Kalman gain matrix or covariance matrices
C     are needed  (JOBCK = 'K', or 'C').  When  JOBCK = 'N',  it could
C     be more efficient to use the combined method,  METH = 'C'.
C     Often, this combination will also provide better accuracy than
C     MOESP algorithm.
C     In some applications, it is useful to compute the system matrices
C     using two calls to this routine, the first one with  JOB = 'C',
C     and the second one with  JOB = 'B' or 'D'.  This is slightly less
C     efficient than using a single call with  JOB = 'A',  because some
C     calculations are repeated. If  METH = 'N',  all the calculations
C     at the first call are performed again at the second call;
C     moreover, it is required to save the needed submatrices of  R
C     before the first call and restore them before the second call.
C     If the covariance matrices and/or the Kalman gain are desired,
C     JOBCK  should be set to  'C'  or  'K'  at the second call.
C     If  B  and  D  are both needed, they should be computed at once.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 1999.
C
C     REVISIONS
C
C     March 2000, August 2000, Sept. 2001, March 2005.
C
C     KEYWORDS
C
C     Identification methods; least squares solutions; multivariable
C     systems; QR decomposition; singular value decomposition.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO  = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      DOUBLE PRECISION   TOL
      INTEGER            INFO, IWARN, L, LDA, LDB, LDC, LDD, LDK, LDQ,
     $                   LDR, LDRY, LDS, LDWORK, M, N, NOBR, NSMPL
      CHARACTER          JOB, JOBCK, METH
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA, *), B(LDB, *), C(LDC, *), D(LDD, *),
     $                   DWORK(*),  K(LDK, *), Q(LDQ, *), R(LDR, *),
     $                   RY(LDRY, *), S(LDS, *)
      INTEGER            IWORK( * )
      LOGICAL            BWORK( * )
C     .. Local Scalars ..
      DOUBLE PRECISION   FERR, RCOND, RCONDR, RNORM, SEP
      INTEGER            I, IA, IAW, IC, ID, IERR, IFACT, IG, IK, IO,
     $                   IQ, IR, IS, IT, IV, IWARNL, IWI, IWR, IX,
     $                   JWORK, LDUNN, LL, LMMNOL, LMNOBR, LNOBR,
     $                   MAXWRK, MINWRK, MNOBR, MNOBRN, N2, NL, NN, NPL,
     $                   NR
      CHARACTER          JOBBD, JOBCOV, JOBCV
      LOGICAL            COMBIN, MOESP, N4SID, WITHAL, WITHB, WITHC,
     $                   WITHCO, WITHD, WITHK
C     .. Local Arrays ..
      DOUBLE PRECISION   RCND(8)
      INTEGER            OUFACT(2)
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           DLACPY, DLASET, IB01PD, MA02AD, SB02MT, SB02ND,
     $                   SB02RD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      MOESP  = LSAME( METH,  'M' )
      N4SID  = LSAME( METH,  'N' )
      COMBIN = LSAME( METH,  'C' )
      WITHAL = LSAME( JOB,   'A' )
      WITHC  = LSAME( JOB,   'C' ) .OR. WITHAL
      WITHD  = LSAME( JOB,   'D' ) .OR. WITHAL
      WITHB  = LSAME( JOB,   'B' ) .OR. WITHD
      WITHK  = LSAME( JOBCK, 'K' )
      WITHCO = LSAME( JOBCK, 'C' ) .OR. WITHK
      MNOBR  = M*NOBR
      LNOBR  = L*NOBR
      LMNOBR = LNOBR + MNOBR
      MNOBRN = MNOBR + N
      LDUNN  = ( LNOBR - L )*N
      LMMNOL = LNOBR + 2*MNOBR + L
      NR     = LMNOBR + LMNOBR
      NPL    = N + L
      N2     = N + N
      NN     = N*N
      NL     = N*L
      LL     = L*L
      MINWRK = 1
      IWARN  = 0
      INFO   = 0
C
C     Check the scalar input parameters.
C
      IF( .NOT.( MOESP .OR. N4SID .OR. COMBIN ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( WITHB .OR. WITHC ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( WITHCO .OR. LSAME( JOBCK, 'N' ) ) ) THEN
         INFO = -3
      ELSE IF( NOBR.LE.1 ) THEN
         INFO = -4
      ELSE IF( N.LE.0 .OR. N.GE.NOBR ) THEN
         INFO = -5
      ELSE IF( M.LT.0 ) THEN
         INFO = -6
      ELSE IF( L.LE.0 ) THEN
         INFO = -7
      ELSE IF( WITHCO .AND. NSMPL.LT.NR ) THEN
         INFO = -8
      ELSE IF( LDR.LT.NR ) THEN
         INFO = -10
      ELSE IF( LDA.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. .NOT.MOESP ) )
     $   .AND. LDA.LT.N ) ) THEN
         INFO = -12
      ELSE IF( LDC.LT.1 .OR. ( ( WITHC .OR. ( WITHB .AND. .NOT.MOESP ) )
     $   .AND. LDC.LT.L ) ) THEN
         INFO = -14
      ELSE IF( LDB.LT.1  .OR. ( WITHB  .AND. LDB.LT.N .AND. M.GT.0 ) )
     $      THEN
         INFO = -16
      ELSE IF( LDD.LT.1  .OR. ( WITHD  .AND. LDD.LT.L .AND. M.GT.0 ) )
     $      THEN
         INFO = -18
      ELSE IF( LDQ.LT.1  .OR. ( WITHCO .AND. LDQ.LT.N ) )  THEN
         INFO = -20
      ELSE IF( LDRY.LT.1 .OR. ( WITHCO .AND. LDRY.LT.L ) ) THEN
         INFO = -22
      ELSE IF( LDS.LT.1  .OR. ( WITHCO .AND. LDS.LT.N ) )  THEN
         INFO = -24
      ELSE IF( LDK.LT.1  .OR. ( WITHK  .AND. LDK.LT.N ) )  THEN
         INFO = -26
      ELSE
C
C        Compute workspace.
C        (Note: Comments in the code beginning "Workspace:" describe the
C         minimal amount of workspace needed at that point in the code,
C         as well as the preferred amount for good performance.)
C
         IAW    = 0
         MINWRK = LDUNN + 4*N
         IF( .NOT.N4SID ) THEN
            ID = 0
            IF( WITHC ) THEN
               MINWRK = MAX( MINWRK, 2*LDUNN + N2, LDUNN + NN + 7*N )
            END IF
         ELSE
            ID = N
         END IF
C
         IF( ( M.GT.0 .AND. WITHB ) .OR. .NOT.MOESP ) THEN
            MINWRK = MAX( MINWRK, 2*LDUNN + NN + ID + 7*N )
            IF ( MOESP )
     $         MINWRK = MAX( MINWRK, LDUNN + N + 6*MNOBR, LDUNN + N +
     $                       MAX( L + MNOBR, LNOBR +
     $                                       MAX( 3*LNOBR + 1, M ) ) )
         ELSE
            IF( .NOT.N4SID )
     $         IAW = N + NN
         END IF
C
         IF( .NOT.MOESP .OR. WITHCO ) THEN
            MINWRK = MAX( MINWRK, LDUNN + IAW + N2 + MAX( 5*N, LMMNOL ),
     $                    ID + 4*MNOBRN + 1, ID + MNOBRN + NPL )
            IF( .NOT.MOESP .AND. M.GT.0 .AND. WITHB )
     $         MINWRK = MAX( MINWRK, MNOBR*NPL*( M*NPL + 1 ) +
     $                       MAX( NPL**2, 4*M*NPL + 1 ) )
            MINWRK = LNOBR*N + MINWRK
         END IF
C
         IF( WITHK ) THEN
            MINWRK = MAX( MINWRK, 4*NN + 2*NL + LL + MAX( 3*L, NL ),
     $                    14*NN + 12*N + 5 )
         END IF
C
         IF ( LDWORK.LT.MINWRK ) THEN
            INFO = -30
            DWORK( 1 ) = MINWRK
         END IF
      END IF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'IB01BD', -INFO )
         RETURN
      END IF
C
      IF ( .NOT.WITHK ) THEN
         JOBCV = JOBCK
      ELSE
         JOBCV = 'C'
      END IF
C
      IO = 1
      IF ( .NOT.MOESP .OR. WITHCO ) THEN
         JWORK = IO + LNOBR*N
      ELSE
         JWORK = IO
      END IF
      MAXWRK = MINWRK
C
C     Call the computational routine for estimating system matrices.
C
      IF ( .NOT.COMBIN ) THEN
         CALL IB01PD( METH, JOB, JOBCV, NOBR, N, M, L, NSMPL, R, LDR,
     $                A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ, RY, LDRY,
     $                S, LDS, DWORK(IO), LNOBR, TOL, IWORK,
     $                DWORK(JWORK), LDWORK-JWORK+1, IWARN, INFO )
C
      ELSE
C
         IF ( WITHC ) THEN
            IF ( WITHAL ) THEN
               JOBCOV = 'N'
            ELSE
               JOBCOV = JOBCV
            END IF
            CALL IB01PD( 'MOESP', 'C and A', JOBCOV, NOBR, N, M, L,
     $                   NSMPL, R, LDR, A, LDA, C, LDC, B, LDB, D, LDD,
     $                   Q, LDQ, RY, LDRY, S, LDS, DWORK(IO), LNOBR,
     $                   TOL, IWORK, DWORK(JWORK), LDWORK-JWORK+1,
     $                   IWARNL, INFO )
            IF ( INFO.NE.0 )
     $         RETURN
            IWARN  = MAX( IWARN, IWARNL )
            MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
         END IF
C
         IF ( WITHB ) THEN
            IF ( .NOT.WITHAL ) THEN
               JOBBD = JOB
            ELSE
               JOBBD = 'D'
            END IF
            CALL IB01PD( 'N4SID', JOBBD, JOBCV, NOBR, N, M, L, NSMPL, R,
     $                LDR, A, LDA, C, LDC, B, LDB, D, LDD, Q, LDQ,
     $                RY, LDRY, S, LDS, DWORK(IO), LNOBR, TOL, IWORK,
     $                DWORK(JWORK), LDWORK-JWORK+1, IWARNL, INFO )
            IWARN  = MAX( IWARN, IWARNL )
         END IF
      END IF
C
      IF ( INFO.NE.0 )
     $   RETURN
      MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
C
      DO 10 I = 1, 4
         RCND(I) = DWORK(JWORK+I)
   10 CONTINUE
C
      IF ( WITHK ) THEN
         IF ( IWARN.EQ.5 ) THEN
C
C           The problem seems to be a deterministic one. Set the Kalman
C           gain to zero, set accuracy parameters and return.
C
            CALL DLASET( 'Full', N, L, ZERO, ZERO, K, LDK )
C
            DO 20 I = 6, 12
               DWORK(I) = ONE
   20       CONTINUE
C
            DWORK(13) = ZERO
         ELSE
C
C           Compute the Kalman gain matrix.
C
C           Convert the optimal problem with coupling weighting terms
C           to a standard problem.
C           Workspace:  need   4*N*N+2*N*L+L*L+max( 3*L,N*L );
C                       prefer larger.
C
            IX    = 1
            IQ    = IX + NN
            IA    = IQ + NN
            IG    = IA + NN
            IC    = IG + NN
            IR    = IC + NL
            IS    = IR + LL
            JWORK = IS + NL
C
            CALL MA02AD( 'Full',  N, N, A,  LDA,  DWORK(IA), N )
            CALL MA02AD( 'Full',  L, N, C,  LDC,  DWORK(IC), N )
            CALL DLACPY( 'Upper', N, N, Q,  LDQ,  DWORK(IQ), N )
            CALL DLACPY( 'Upper', L, L, RY, LDRY, DWORK(IR), L )
            CALL DLACPY( 'Full',  N, L, S,  LDS,  DWORK(IS), N )
C
            CALL SB02MT( 'G needed', 'Nonzero S', 'Not factored',
     $                   'Upper', N, L, DWORK(IA), N, DWORK(IC), N,
     $                   DWORK(IQ), N, DWORK(IR), L, DWORK(IS), N,
     $                   IWORK, IFACT, DWORK(IG), N, IWORK(L+1),
     $                   DWORK(JWORK), LDWORK-JWORK+1, IERR )
            IF ( IERR.NE.0 ) THEN
               INFO = 3
               RETURN
            END IF
            MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
            RCONDR = DWORK(JWORK+1)
C
C           Solve the Riccati equation.
C           Workspace:  need   14*N*N+12*N+5;
C                       prefer larger.
C
            IT    = IC
            IV    = IT  + NN
            IWR   = IV  + NN
            IWI   = IWR + N2
            IS    = IWI + N2
            JWORK = IS  + N2*N2
C
            CALL SB02RD( 'All', 'Discrete', 'Direct', 'NoTranspose',
     $                   'Upper', 'General scaling', 'Unstable first',
     $                   'Not factored', 'Reduced', N, DWORK(IA), N,
     $                   DWORK(IT), N, DWORK(IV), N, DWORK(IG), N,
     $                   DWORK(IQ), N, DWORK(IX), N, SEP, RCOND, FERR,
     $                   DWORK(IWR), DWORK(IWI), DWORK(IS), N2, IWORK,
     $                   DWORK(JWORK), LDWORK-JWORK+1, BWORK, IERR )
C
            IF ( IERR.NE.0 .AND. IERR.LT.7 ) THEN
               INFO = IERR + 3
               RETURN
            END IF
            MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
C
            DO 30 I = 1, 4
               RCND(I+4) = DWORK(JWORK+I)
   30       CONTINUE
C
C           Compute the gain matrix.
C           Workspace:  need   2*N*N+2*N*L+L*L+3*L;
C                       prefer larger.
C
            IA    = IX + NN
            IC    = IA + NN
            IR    = IC + NL
            IK    = IR + LL
            JWORK = IK + NL
C
            CALL MA02AD( 'Full',  N, N, A,  LDA,  DWORK(IA), N )
            CALL MA02AD( 'Full',  L, N, C,  LDC,  DWORK(IC), N )
            CALL DLACPY( 'Upper', L, L, RY, LDRY, DWORK(IR), L )
C
            CALL SB02ND( 'Discrete', 'NotFactored', 'Upper',
     $                   'Nonzero S', N, L, 0, DWORK(IA), N, DWORK(IC),
     $                   N, DWORK(IR), L, IWORK, S, LDS, DWORK(IX), N,
     $                   RNORM, DWORK(IK), L, OUFACT, IWORK(L+1),
     $                   DWORK(JWORK), LDWORK-JWORK+1, IERR )
C
            IF ( IERR.NE.0 ) THEN
               IF ( IERR.LE.L+1 ) THEN
                  INFO = 3
               ELSE IF ( IERR.EQ.L+2 ) THEN
                  INFO = 10
               END IF
               RETURN
            END IF
            MAXWRK = MAX( MAXWRK, INT( DWORK(JWORK) ) + JWORK - 1 )
C
            CALL MA02AD( 'Full', L, N, DWORK(IK), L, K, LDK )
C
C           Set the accuracy parameters.
C
            DWORK(11) = DWORK(JWORK+1)
C
            DO 40 I = 6, 9
               DWORK(I) = RCND(I-1)
   40       CONTINUE
C
            DWORK(10) = RCONDR
            DWORK(12) = RCOND
            DWORK(13) = FERR
         END IF
      END IF
C
C     Return optimal workspace in  DWORK(1)  and the remaining
C     reciprocal condition numbers in the next locations.
C
      DWORK(1) = MAXWRK
C
      DO 50 I = 2, 5
         DWORK(I) = RCND(I-1)
   50 CONTINUE
C
      RETURN
C
C *** Last line of IB01BD ***
      END


! { dg-do  run }
! Check that simplification of minloc works
program main
  implicit none
  integer :: d
  real, dimension(2), parameter :: a = [1.0, 0.0]
  character(len=3), dimension(3), parameter :: c = [ "fgh", "asd", "jkl" ]
  integer, parameter :: b = minloc(a,dim=1)
  integer, parameter :: b2 = minloc(a,dim=1,mask=[.false.,.false.])
  integer, parameter :: b3 = minloc(c,dim=1)
  integer, parameter :: b4 = minloc(c,dim=1,mask=[c>"bbb"])
  integer, parameter,dimension(2,2) :: i1 = reshape([4,3,2,5],shape(i1))
  integer, parameter, dimension(2) :: b5 = minloc(i1)
  integer, parameter, dimension(2) :: b6 = minloc(i1,mask=i1>7)
  integer, parameter, dimension(2) :: b7 = minloc(i1, mask=i1>2)
  integer, parameter, dimension(2) :: b8 = minloc(i1, mask=.true.)
  integer, parameter, dimension(2) :: b9 = minloc(i1, mask=.false.)
  integer, parameter, dimension(2,3) :: i2 = &
       reshape([2, -1, -3, 4, -5, 6], shape(i2))
  integer, parameter, dimension(3) :: b10 = minloc(i2, dim=1)
  integer, parameter, dimension(2) :: b11 = minloc(i2, dim=2)
  integer, parameter, dimension(3) :: b12 = minloc(i2,dim=1,mask=i2>3)
  integer, parameter, dimension(2) :: b13 = minloc(i2,dim=2, mask=i2<-10)
  if (b /= 2) STOP 1
  if (b2 /= 0) STOP 2
  if (b3 /= 2) STOP 3
  if (b4 /= 1) STOP 4
  if (any(b5 /= [1, 2])) STOP 5
  if (any(b6 /= [0, 0])) STOP 6
  if (any(b7 /= [2, 1])) STOP 7
  if (any(b8 /= [1, 2])) STOP 8
  if (any(b9 /= [0, 0])) STOP 9
  d = 1
  if (any(b10 /= minloc(i2,dim=d))) STOP 10
  d = 2
  if (any(b11 /= minloc(i2,dim=2))) STOP 11
  d = 1
  if (any(b12 /= minloc(i2, dim=d,mask=i2>3))) STOP 12
  if (any(b13 /= 0)) STOP 13
end program main


C FILE: MBX_FORTRAN_TEST.F90
	  SUBROUTINE CALC_MAX9(ret, d)
	  implicit none
C
C     Calc background
C
      REAL*8 arr(9*2+(9-2)*2)											! g = gaussian result
	  REAL*8 ret
	  REAL*8 d(9,9)														! d = data = pixel values
Cf2py intent(in) d														! intent(in) means input
Cf2py intent(out) ret													! intent(out) means only this will be returned
Cf2py depend(d) ret

      arr(1:9) = d(:,1)
	  arr(10:18) = d(:,9)
	  arr(19:25) = d(2:8,1)
	  arr(26:32) = d(2:8,9)

	  ret = sum(arr)/32

      END

	  SUBROUTINE NORM5(ret, d)
	  implicit none
C
C     Norm for 5 variables
C
      REAL*8 d(5)											! g = gaussian result
	  REAL*8 ret													! d = data = pixel values
	  INTEGER i
Cf2py intent(in) d														! intent(in) means input
Cf2py intent(out) ret													! intent(out) means only this will be returned
Cf2py depend(d) ret

      ret = 0

	  do i = 1,5
		if (d(i) .gt. ret) then
		ret = d(i)
		endif
		if (-d(i) .gt. ret) then
		ret = -d(i)
		endif
	  enddo

      END

	  SUBROUTINE NORM5_2(ret, d)
	  implicit none
C
C     Norm for 5 variables
C
      REAL*8 d(5)											! g = gaussian result
	  REAL*8 ret													! d = data = pixel values
	  INTEGER i
Cf2py intent(in) d														! intent(in) means input
Cf2py intent(out) ret													! intent(out) means only this will be returned
Cf2py depend(d) ret

      ret = 0

	  do i = 1,5
		if (abs(d(i)) .gt. ret) then
		ret = abs(d(i))
		endif
	  enddo

      END

	  SUBROUTINE NORM5_3(ret, d)
	  implicit none
C
C     Norm for 5 variables
C
      REAL*8 d(5)											! g = gaussian result
	  REAL*8 ret													! d = data = pixel values
	  INTEGER i
Cf2py intent(in) d														! intent(in) means input
Cf2py intent(out) ret													! intent(out) means only this will be returned
Cf2py depend(d) ret

      ret = maxval(abs(d))

      END

	  SUBROUTINE MAX9(ret, d)
	  implicit none
C
C     Norm for 5 variables
C
      REAL*8 d(9,9)											! g = gaussian result
	  REAL*8 ret													! d = data = pixel values
Cf2py intent(in) d														! intent(in) means input
Cf2py intent(out) ret													! intent(out) means only this will be returned
Cf2py depend(d) ret

	  ret = maxval(d)

      END

	  SUBROUTINE MAX7(ret, d)
	  implicit none
C
C     Norm for 5 variables
C
      REAL*8 d(7,7)											! g = gaussian result
	  REAL*8 ret													! d = data = pixel values
Cf2py intent(in) d														! intent(in) means input
Cf2py intent(out) ret													! intent(out) means only this will be returned
Cf2py depend(d) ret

	  ret = maxval(d)

      END

	  SUBROUTINE FFT9(x_re, x_im, y_re, y_im, d)
	  implicit none
C
C     FFT for 9x9 ROI
C
      REAL*8 d(9,9)											! g = gaussian result
	  REAL*8 x_re, y_re, y_im, x_im							! d = data = pixel values
	  REAL*8 fit_o(9), fit_cos(9), fit_sin(9)
	  REAL*8 loop_x_im(9), loop_x_re(9), loop_y_im(9), loop_y_re(9)
	  real*8 pi
	  INTEGER s, i, j
Cf2py intent(in) d											! intent(in) means input
Cf2py intent(out) x_re, y_re, y_im, x_im					! intent(out) means only this will be returned
Cf2py depend(d) x_re, y_re, y_im, x_im

	  s = 9
	  pi = 2.d0 * asin(1.d0)

	  do i = 1, s
	  fit_o(i) = i*2*pi/s
	  fit_cos(i) = cos(fit_o(i))
	  fit_sin(i) = sin(fit_o(i))
	  loop_x_re(i) = 0
	  loop_x_im(i) = 0
	  loop_y_re(i) = 0
	  loop_y_im(i) = 0
	  enddo

	  do i=1, s
	  do j=1, s
	  loop_x_re(j) = loop_x_re(j) + fit_cos(j)*d(i,j)
	  loop_x_im(j) = loop_x_im(j) - fit_sin(j)*d(i,j)
	  loop_y_re(i) = loop_y_re(i) + fit_cos(i)*d(i,j)
	  loop_y_im(i) = loop_y_im(i) - fit_sin(i)*d(i,j)
	  enddo
	  enddo

	  x_re = sum(loop_x_re)
	  x_im = sum(loop_x_im)
	  y_re = sum(loop_y_re)
	  y_im = sum(loop_y_im)

      END

C END FILE MBX_FORTRAN_TEST.F90


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!> @brief A Fortran 2003 module implementing some basic sorting algorithms.
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
MODULE Sorting

USE IntrType
USE Strings
IMPLICIT NONE

PUBLIC :: sort
PUBLIC :: insert_sort
PUBLIC :: bubble_sort

!> @brief Generic interface to sort arrays.
!>
INTERFACE sort
  !> @copybrief Sorting::qsort_1DReal
  !> @copydetails Sorting::qsort_1DReal
  MODULE PROCEDURE qsort_1DReal
  !> @copybrief Sorting::qsort_1DInt
  !> @copydetails Sorting::qsort_1DInt
  MODULE PROCEDURE qsort_1DInt
  !> @copybrief Sorting::qsort_1DStr
  !> @copydetails Sorting::qsort_1DStr
  MODULE PROCEDURE qsort_1DStr
  !> @copybrief Sorting::qsort_1DLong_1DInt
  !> @copydetails Sorting::qsort_1DLong_1DInt
  MODULE PROCEDURE qsort_1DLong_1DInt
  !> @copybrief Sorting::bubble_sort_2DInt
  !> @copydetails Sorting::bubble_sort_2DInt
  MODULE PROCEDURE bubble_sort_2DInt
  !> @copybrief Sorting::bubble_sort_1DReal_1DReal
  !> @copydetails Sorting::bubble_sort_1DReal_1DReal
  MODULE PROCEDURE bubble_sort_1DReal_1DReal
  !> @copybrief Sorting::bubble_sort_1DReal_1DInt
  !> @copydetails Sorting::bubble_sort_1DReal_1DInt
  MODULE PROCEDURE bubble_sort_1DReal_1DInt
  !> @copybrief Sorting::bubble_sort_1DInt_1DInt
  !> @copydetails Sorting::bubble_sort_1DInt_1DInt
  MODULE PROCEDURE bubble_sort_1DInt_1DInt
  !> @copybrief Sorting::bubble_sort_1DInt_1DStr
  !> @copydetails Sorting::bubble_sort_1DInt_1DStr
  MODULE PROCEDURE bubble_sort_1DInt_1DStr
ENDINTERFACE sort

!> @brief Generic interface to sort arrays with insertion sort.
!>
INTERFACE insert_sort
  !> @copybrief Sorting::insert_sort_int
  !> @copydetails Sorting::insert_sort_int
  MODULE PROCEDURE insert_sort_int
  !> @copybrief Sorting::insert_sort_real
  !> @copydetails Sorting::insert_sort_real
  MODULE PROCEDURE insert_sort_real
  !> @copybrief Sorting::insert_sort_str
  !> @copydetails Sorting::insert_sort_str
  MODULE PROCEDURE insert_sort_str
  !> @copybrief Sorting::insert_sort_1DLong_1DInt
  !> @copydetails Sorting::insert_sort_1DLong_1DInt
  MODULE PROCEDURE insert_sort_1DLong_1DInt
ENDINTERFACE insert_sort

!> @brief Generic interface to sort arrays with bubble sort.
!>
INTERFACE bubble_sort
  !> @copybrief Sorting::bubble_sort_1DReal
  !> @copydetails Sorting::bubble_sort_1DReal
  MODULE PROCEDURE bubble_sort_1DReal
  !> @copybrief Sorting::bubble_sort_1DInt
  !> @copydetails Sorting::bubble_sort_1DInt
  MODULE PROCEDURE bubble_sort_1DInt
  !> @copybrief Sorting::bubble_sort_2DInt
  !> @copydetails Sorting::bubble_sort_2DInt
  MODULE PROCEDURE bubble_sort_2DInt
  !> @copybrief Sorting::bubble_sort_1DReal_1DReal
  !> @copydetails Sorting::bubble_sort_1DReal_1DReal
  MODULE PROCEDURE bubble_sort_1DReal_1DReal
  !> @copybrief Sorting::bubble_sort_1DReal_1DInt
  !> @copydetails Sorting::bubble_sort_1DReal_1DInt
  MODULE PROCEDURE bubble_sort_1DReal_1DInt
  !> @copybrief Sorting::bubble_sort_1DReal_1DStr
  !> @copydetails Sorting::bubble_sort_1DReal_1DStr
  MODULE PROCEDURE bubble_sort_1DReal_1DStr
  !> @copybrief Sorting::bubble_sort_1DInt_1DInt
  !> @copydetails Sorting::bubble_sort_1DInt_1DInt
  MODULE PROCEDURE bubble_sort_1DInt_1DInt
  !> @copybrief Sorting::bubble_sort_1DInt_1DStr
  !> @copydetails Sorting::bubble_sort_1DInt_1DStr
  MODULE PROCEDURE bubble_sort_1DInt_1DStr

ENDINTERFACE bubble_sort
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
!> @brief A simple sorting algorithm for a 1-D real vector sort.  The arguments
!>        data will be sorted in ascending/increasing order and returned.
!> @param r A vector of unsorted reals
!>
PURE SUBROUTINE bubble_sort_1DReal(r)
  REAL(SRK),INTENT(INOUT) :: r(:)
  !LOGICAL(SBK),INTENT(IN),OPTIONAL :: reverse
  LOGICAL(SBK) :: sorted
  INTEGER(SIK) :: i,ncomp
  REAL(SRK) :: tmp

  sorted=.FALSE.
  ncomp=0
  DO WHILE(.NOT.sorted)
    sorted=.TRUE.
    ncomp=ncomp+1
    DO i=1,SIZE(r)-ncomp
      IF(r(i) > r(i+1)) THEN
        tmp=r(i+1)
        r(i+1)=r(i)
        r(i)=tmp
        sorted=.FALSE.
      ENDIF
    ENDDO
  ENDDO

ENDSUBROUTINE bubble_sort_1DReal
!
!-------------------------------------------------------------------------------
!> @brief A simple sorting algorithm for a 1-D integer vector sort.  The
!>        arguments data will be sorted in ascending/increasing order and
!>        returned.
!> @param r A vector of unsorted integers
!>
PURE SUBROUTINE bubble_sort_1DInt(r)
  INTEGER(SIK),INTENT(INOUT) :: r(:)
  !LOGICAL(SBK),INTENT(IN),OPTIONAL :: reverse
  LOGICAL(SBK) :: sorted
  INTEGER(SIK) :: i,ncomp
  INTEGER(SIK) :: tmp

  sorted=.FALSE.
  ncomp=0
  DO WHILE(.NOT.sorted)
    sorted=.TRUE.
    ncomp=ncomp+1
    DO i=1,SIZE(r)-ncomp
      IF(r(i) > r(i+1)) THEN
        tmp=r(i+1)
        r(i+1)=r(i)
        r(i)=tmp
        sorted=.FALSE.
      ENDIF
    ENDDO
  ENDDO

ENDSUBROUTINE bubble_sort_1DInt
!
!-------------------------------------------------------------------------------
!> @brief A simple sorting algorithm for a 2-D integer array sort.  The
!>        arguments data will be sorted in ascending/increasing order and
!>        returned.
!> @param r A 2-D array of unsorted integers
!>
PURE SUBROUTINE bubble_sort_2DInt(r)
  INTEGER(SIK),INTENT(INOUT) :: r(:,:)
  !LOGICAL(SBK),INTENT(IN),OPTIONAL :: reverse
  LOGICAL(SBK) :: sorted
  INTEGER(SIK) :: i1,i2,j1,j2,ni,nj,n,ncomp
  INTEGER(SIK) :: tmp

  sorted=.FALSE.
  ni=SIZE(r,DIM=1)
  nj=SIZE(r,DIM=2)
  ncomp=0
  DO WHILE(.NOT.sorted)
    sorted=.TRUE.
    ncomp=ncomp+1
    DO n=1,ni*nj-ncomp
      i1=MOD(n-1,ni)+1
      j1=(n-1)/ni+1
      i2=MOD(n,ni)+1
      j2=(n)/ni+1
      IF(r(i1,j1) > r(i2,j2)) THEN
        tmp=r(i2,j2)
        r(i2,j2)=r(i1,j1)
        r(i1,j1)=tmp
        sorted=.FALSE.
      ENDIF
    ENDDO
  ENDDO

ENDSUBROUTINE bubble_sort_2DInt
!
!-------------------------------------------------------------------------------
!> @brief A simple sorting algorithm for a 2 1-D array sorting.  The first array's
!>        data will be sorted in ascending/increasing order and returned.  The
!>        second array's data will be sorted positionally based on the first arrays
!>        sorting.
!> @example
!>        real1=(/5.0_SRK,-1.0_SRK,10.0_SRK/)
!>        real2=(/-1.0_SRK,-2.0_SRK,-3.0_SRK/)
!>        CALL bubble_sort_1DReal_1Dreal(real1,real2)
!>        real1=(/-1.0_SRK,5.0_SRK,10.0_SRK/)
!>        real2=(/-2.0_SRK,-1.0_SRK,-3.0_SRK/)
!>        !Reverse the arguments
!>        CALL bubble_sort_1DReal_1Dreal(real2,real1)
!>        real1=(/10.0_SRK,-1.0_SRK,5.0_SRK/)
!>        real2=(/-3.0_SRK,-2.0_SRK,-1.0_SRK/)
!> @param real1 A 1-D array of unsorted reals
!> @param real2 A 1-D array of unsorted reals
!>
PURE SUBROUTINE bubble_sort_1DReal_1DReal(real1,real2)
  REAL(SRK),INTENT(INOUT) :: real1(:)
  REAL(SRK),INTENT(INOUT) :: real2(:)
  !LOGICAL(SBK),INTENT(IN),OPTIONAL :: reverse
  LOGICAL(SBK) :: sorted
  INTEGER(SIK) :: i,ni,nr,ncomp
  REAL(SRK) :: tmpr

  sorted=.FALSE.
  ni=SIZE(real1,DIM=1)
  nr=SIZE(real2,DIM=1)
  ncomp=0
  IF(ni == nr) THEN
    DO WHILE(.NOT.sorted)
      sorted=.TRUE.
      ncomp=ncomp+1
      DO i=1,ni-ncomp
        IF(real1(i) > real1(i+1)) THEN
          tmpr=real1(i+1)
          real1(i+1)=real1(i)
          real1(i)=tmpr
          tmpr=real2(i+1)
          real2(i+1)=real2(i)
          real2(i)=tmpr
          sorted=.FALSE.
        ENDIF
      ENDDO
    ENDDO
  ENDIF
ENDSUBROUTINE bubble_sort_1DReal_1DReal
!
!-------------------------------------------------------------------------------
!> @brief A simple sorting algorithm for a 2 1-D array sorting.  The first array's
!>        data will be sorted in ascending/increasing order and returned.  The
!>        second array's data will be sorted positionally based on the first arrays
!>        sorting.
!> @example
!>        real1=(/5.0_SRK,-1.0_SRK,10.0_SRK/)
!>        int1=(/-1.0_SRK,-2.0_SRK,-3.0_SRK/)
!>        CALL bubble_sort_1DReal_1DInt(real1,int1)
!>        real1=(/-1.0_SRK,5.0_SRK,10.0_SRK/)
!>        int1=(/-2.0_SRK,-1.0_SRK,-3.0_SRK/)
!> @param real1 A 1-D array of unsorted reals
!> @param int1 A 1-D array of unsorted integers
!>
PURE SUBROUTINE bubble_sort_1DReal_1DInt(real1,int1,sortreal)
  REAL(SRK),INTENT(INOUT) :: real1(:)
  INTEGER(SIK),INTENT(INOUT) :: int1(:)
  LOGICAL(SBK),INTENT(IN) :: sortreal
  !LOGICAL(SBK),INTENT(IN),OPTIONAL :: reverse
  LOGICAL(SBK) :: sorted
  INTEGER(SIK) :: i,ni,nr,ncomp,tmpi
  REAL(SRK) :: tmpr

  sorted=.FALSE.
  ni=SIZE(real1,DIM=1)
  nr=SIZE(int1,DIM=1)
  ncomp=0
  IF(ni == nr) THEN
    IF(sortreal) THEN
      DO WHILE(.NOT.sorted)
        sorted=.TRUE.
        ncomp=ncomp+1
        DO i=1,ni-ncomp
          IF(real1(i) > real1(i+1)) THEN
            tmpr=real1(i+1)
            real1(i+1)=real1(i)
            real1(i)=tmpr
            tmpi=int1(i+1)
            int1(i+1)=int1(i)
            int1(i)=tmpi
            sorted=.FALSE.
          ENDIF
        ENDDO
      ENDDO
    ELSE
      DO WHILE(.NOT.sorted)
        sorted=.TRUE.
        ncomp=ncomp+1
        DO i=1,ni-ncomp
          IF(int1(i) > int1(i+1)) THEN
            tmpi=int1(i+1)
            int1(i+1)=int1(i)
            int1(i)=tmpi
            tmpr=real1(i+1)
            real1(i+1)=real1(i)
            real1(i)=tmpr
            sorted=.FALSE.
          ENDIF
        ENDDO
      ENDDO
    ENDIF
  ENDIF
ENDSUBROUTINE bubble_sort_1DReal_1DInt
!
!-------------------------------------------------------------------------------
!> @brief A simple sorting algorithm for a 2 1-D array sorting.  The first array's
!>        data will be sorted in ascending/increasing order and returned.  The
!>        second array's data will be sorted positionally based on the first arrays
!>        sorting.
!> @example
!>        real1=(/5,-1,10/)
!>        str1=(/'g','a','d'/)
!>        CALL bubble_sort_1DReal_1DStr(real1,str1)
!>        real1=(/-1,5,10/)
!>        str1=(/'a','g','d'/)
!> @param real1 A 1-D array of unsorted reals
!> @param str1 A 1-D array of unsorted strings
!>
PURE SUBROUTINE bubble_sort_1DReal_1DStr(real1,str1)
  REAL(SRK),INTENT(INOUT) :: real1(:)
  TYPE(StringType),INTENT(INOUT) :: str1(:)
  !LOGICAL(SBK),INTENT(IN),OPTIONAL :: reverse
  LOGICAL(SBK) :: sorted
  INTEGER(SIK) :: i,ni,nr,ncomp
  TYPE(StringType) :: tmpstr,tmpstr2
  REAL(SRK) :: tmpr

  sorted=.FALSE.
  ni=SIZE(real1,DIM=1)
  nr=SIZE(str1,DIM=1)
  ncomp=0
  IF(ni == nr) THEN
    DO WHILE(.NOT.sorted)
      sorted=.TRUE.
      ncomp=ncomp+1
      DO i=1,ni-ncomp
        IF(real1(i) > real1(i+1)) THEN
          tmpr=real1(i+1)
          real1(i+1)=real1(i)
          real1(i)=tmpr
          tmpstr=str1(i+1)
          tmpstr2=str1(i)
          str1(i+1)=tmpstr2
          !str1(i+1)=str1(i)
          str1(i)=tmpstr
          sorted=.FALSE.
        ENDIF
      ENDDO
    ENDDO
  ENDIF
ENDSUBROUTINE bubble_sort_1DReal_1DStr
!
!-------------------------------------------------------------------------------
!> @brief A simple sorting algorithm for a 2 1-D array sorting.  The first array's
!>        data will be sorted in ascending/increasing order and returned.  The
!>        second array's data will be sorted positionally based on the first arrays
!>        sorting.
!> @example
!>        int1=(/5,-1,10/)
!>        int2=(/-1,-2,-3/)
!>        CALL bubble_sort_1DInt_1DInt(int1,int2)
!>        int1=(/-1,5,10/)
!>        int2=(/-2,-1,-3/)
!>        !Reverse the arguments
!>        CALL bubble_sort_1DInt_1DInt(int2,int1)
!>        int1=(/10,-1,5/)
!>        int2=(/-3,-2,-1/)
!> @param real1 A 1-D array of unsorted reals
!> @param real2 A 1-D array of unsorted reals
!>
PURE SUBROUTINE bubble_sort_1DInt_1DInt(int1,int2)
  INTEGER(SIK),INTENT(INOUT) :: int1(:)
  INTEGER(SIK),INTENT(INOUT) :: int2(:)
  !LOGICAL(SBK),INTENT(IN),OPTIONAL :: reverse
  LOGICAL(SBK) :: sorted
  INTEGER(SIK) :: i,ni,nr,ncomp
  INTEGER(SIK) :: tmpi,tmpi2

  sorted=.FALSE.
  ni=SIZE(int1,DIM=1)
  nr=SIZE(int2,DIM=1)
  ncomp=0
  IF(ni == nr) THEN
    DO WHILE(.NOT.sorted)
      sorted=.TRUE.
      ncomp=ncomp+1
      DO i=1,ni-ncomp
        IF(int1(i) > int1(i+1)) THEN
          tmpi=int1(i+1)
          int1(i+1)=int1(i)
          int1(i)=tmpi
          tmpi2=int2(i+1)
          int2(i+1)=int2(i)
          int2(i)=tmpi2
          sorted=.FALSE.
        ENDIF
      ENDDO
    ENDDO
  ENDIF
ENDSUBROUTINE bubble_sort_1DInt_1DInt
!
!-------------------------------------------------------------------------------
!> @brief A simple sorting algorithm for a 2 1-D array sorting.  The first array's
!>        data will be sorted in ascending/increasing order and returned.  The
!>        second array's data will be sorted positionally based on the first arrays
!>        sorting.
!> @example
!>        int1=(/5,-1,10/)
!>        str1=(/'g','a','d'/)
!>        CALL bubble_sort_1DInt_1DStr(int1,str1)
!>        int1=(/-1,5,10/)
!>        str1=(/'a','g','d'/)
!> @param int1 A 1-D array of unsorted integers
!> @param str1 A 1-D array of unsorted strings
!>
PURE SUBROUTINE bubble_sort_1DInt_1DStr(int1,str1)
  INTEGER(SIK),INTENT(INOUT) :: int1(:)
  TYPE(StringType),INTENT(INOUT) :: str1(:)
  !LOGICAL(SBK),INTENT(IN),OPTIONAL :: reverse
  LOGICAL(SBK) :: sorted
  INTEGER(SIK) :: i,ni,nr,ncomp
  INTEGER(SIK) :: tmpi
  TYPE(StringType) :: tmpstr,tmpstr2

  sorted=.FALSE.
  ni=SIZE(int1,DIM=1)
  nr=SIZE(str1,DIM=1)
  ncomp=0
  IF(ni == nr) THEN
    DO WHILE(.NOT.sorted)
      sorted=.TRUE.
      ncomp=ncomp+1
      DO i=1,ni-ncomp
        IF(int1(i) > int1(i+1)) THEN
          tmpi=int1(i+1)
          int1(i+1)=int1(i)
          int1(i)=tmpi
          tmpstr=str1(i+1)
          tmpstr2=str1(i)
          str1(i+1)=tmpstr2
          str1(i)=tmpstr
          sorted=.FALSE.
        ENDIF
      ENDDO
    ENDDO
  ENDIF
ENDSUBROUTINE bubble_sort_1DInt_1DStr
!-------------------------------------------------------------------------------
!  Insert Sort
!-------------------------------------------------------------------------------
!> @brief Sorts a list of integers using the insert sort algorithm
!> @param list the list to be sorted
PURE SUBROUTINE insert_sort_int(list)
  INTEGER(SIK),INTENT(INOUT) :: list(:)
  !
  INTEGER(SIK) :: key,i,j,n

  n=SIZE(list)

  DO i=2,n
    key = list(i)
    j=i-1
    DO WHILE(list(j) > key)
      list(j+1) = list(j)
      j=j-1
      IF (j < 1) EXIT
    ENDDO
    list(j+1)=key
  ENDDO
ENDSUBROUTINE insert_sort_int
!
!-------------------------------------------------------------------------------
!> @brief Sorts a list of integers using the insert sort algorithm
!> @param list the list to be sorted
PURE SUBROUTINE insert_sort_real(list)
  REAL(SRK),INTENT(INOUT) :: list(:)
  !
  REAL(SRK) :: key
  INTEGER(SIK) :: i,j,n

  n=SIZE(list)

  DO i=2,n
    key = list(i)
    j=i-1
    DO WHILE(list(j) > key)
      list(j+1) = list(j)
      j=j-1
      IF (j < 1) EXIT
    ENDDO
    list(j+1)=key
  ENDDO
ENDSUBROUTINE insert_sort_real
!
!-------------------------------------------------------------------------------
!> @brief Sorts a list of strings using the insert sort algorithm
!> @param list the list to be sorted
PURE SUBROUTINE insert_sort_str(list)
  TYPE(StringType),INTENT(INOUT) :: list(:)
  !
  INTEGER(SIK) :: i,j,n
  TYPE(StringType) :: key

  n=SIZE(list)

  DO i=2,n
    key = list(i)
    j=i-1
    DO WHILE(list(j) > key)
      list(j+1) = list(j)
      j=j-1
      IF (j < 1) EXIT
    ENDDO
    list(j+1)=key
  ENDDO
ENDSUBROUTINE insert_sort_str
!
!-------------------------------------------------------------------------------
!> @brief Sorts a list of long keys and integer values using the insert sort
!>        algorithm
!> @param keys the key values to sort over
!> @param vals the data values to move with key
    PURE SUBROUTINE insert_sort_1DLong_1DInt(keys,vals)
      INTEGER(SLK),INTENT(INOUT) :: keys(:)
      INTEGER(SIK),INTENT(INOUT) :: vals(:)
      !
      INTEGER(SLK) :: key
      INTEGER(SIK) :: i,j,n,val

      n=SIZE(vals)
      DO i=2,n
        key=keys(i)
        val=vals(i)
        j=i-1
        DO WHILE(keys(j) > key)
          keys(j+1)=keys(j)
          vals(j+1)=vals(j)
          j=j-1
          IF (j < 1) EXIT
        ENDDO
        keys(j+1)=key
        vals(j+1)=val
      ENDDO
    ENDSUBROUTINE insert_sort_1DLong_1DInt
!
!-------------------------------------------------------------------------------
!  QuickSort
!-------------------------------------------------------------------------------
!> @brief QuickSort 1D integer array
!> @param A 1D integer array, modified in place and returned sorted
!>
PURE RECURSIVE SUBROUTINE qsort_1DInt(A)
  INTEGER(SIK),INTENT(INOUT) :: A(:)

  INTEGER(SIK) :: n,l,p,c

  n=SIZE(A)

  IF (n>50) THEN
    !median of 3 pivot
    c=n/2
    IF (A(c) < A(1)) CALL swap_int(A,c,1)
    IF (A(n) < A(1)) CALL swap_int(A,1,n)
    IF (A(n) < A(c)) CALL swap_int(A,c,n)
    p=c
   ! p=1  ! left most pivot
   ! p=FLOOR(RAND()*REAL(n,SRK),SIK)+1  ! Randomized pivot
    CALL partition_array_1DInt(A,p,l)
    CALL qsort_1DInt(A(1:l-1))
    CALL qsort_1DInt(A(l+1:n))
  ELSE
    CALL insert_sort_int(A)
  ENDIF
ENDSUBROUTINE qsort_1DInt
!-------------------------------------------------------------------------------
!> @brief QuickSort 1D string array
!> @param A 1D string array, modified in place and returned sorted
!>
PURE RECURSIVE SUBROUTINE qsort_1DStr(A)
  TYPE(StringType),INTENT(INOUT) :: A(:)

  INTEGER(SIK) :: n,l,p,c

  n=SIZE(A)

  IF (n>50) THEN
    !median of 3 pivot
    c=n/2
    IF (A(c) < A(1)) CALL swap_str(A,c,1)
    IF (A(n) < A(1)) CALL swap_str(A,1,n)
    IF (A(n) < A(c)) CALL swap_str(A,c,n)
    p=c
   ! p=1  ! left most pivot
   ! p=FLOOR(RAND()*REAL(n,SRK),SIK)+1  ! Randomized pivot
    CALL partition_array_1DStr(A,p,l)
    CALL qsort_1DStr(A(1:l-1))
    CALL qsort_1DStr(A(l+1:n))
  ELSE
    CALL insert_sort_str(A)
  ENDIF
ENDSUBROUTINE qsort_1DStr
!
!-------------------------------------------------------------------------------
!> @brief Partition method 1D integer array.  For a given partion, sorts values
!>         greater than and less than the partition
!> @param A 1D integer array, modified in place and returned partioned
!> @param p Index of array element to partition with
!> @param i Index of the partition element once A is partitioned
!>
PURE SUBROUTINE partition_array_1DInt(A,p,i)
  INTEGER(SIK),INTENT(INOUT) :: A(:)
  INTEGER(SIK),INTENT(IN) :: p
  INTEGER(SIK),INTENT(OUT) :: i

  INTEGER(SIK) :: j,n,pval

  pval=A(p)
  n=SIZE(A)
  IF (p>1) THEN
    ! if Mo3 sort, 1st element is smaller than pivot, don't throw away
    CALL swap_int(A,1,2)
    CALL swap_int(A,1,p)
  ENDIF

  i=2
  DO j=2,n
    IF (A(j)<pval) THEN
      CALL swap_int(A,i,j)
      i=i+1
    ENDIF
  ENDDO
  i=i-1
  CALL swap_int(A,1,i)
ENDSUBROUTINE partition_array_1DInt
!
!-------------------------------------------------------------------------------
!> @brief Partition method 1D string array.  For a given partion, sorts values
!>         greater than and less than the partition
!> @param A 1D string array, modified in place and returned partioned
!> @param p Index of array element to partition with
!> @param i Index of the partition element once A is partitioned
!>
PURE SUBROUTINE partition_array_1DStr(A,p,i)
  TYPE(StringType),INTENT(INOUT) :: A(:)
  INTEGER(SIK),INTENT(IN) :: p
  INTEGER(SIK),INTENT(OUT) :: i

  INTEGER(SIK) :: j,n
  TYPE(StringType) :: pval

  pval=A(p)
  n=SIZE(A)
  IF (p>1) THEN
    ! if Mo3 sort, 1st element is smaller than pivot, don't throw away
    CALL swap_str(A,1,2)
    CALL swap_str(A,1,p)
  ENDIF

  i=2
  DO j=2,n
    IF (A(j)<pval) THEN
      CALL swap_str(A,i,j)
      i=i+1
    ENDIF
  ENDDO
  i=i-1
  CALL swap_str(A,1,i)
ENDSUBROUTINE partition_array_1DStr

!
!-------------------------------------------------------------------------------
!> @brief Quicksort 1D array of Ints and apply same sorting operations to
!> 1D array of Reals
!> @param keys Integers to sort over
!> @param values ints to sort based on keys
PURE RECURSIVE SUBROUTINE qsort_1DLong_1DInt(keys, values)
  INTEGER(SLK),INTENT(INOUT) :: keys(:)
  INTEGER(SIK),INTENT(INOUT) :: values(:)

  INTEGER(SIK) :: n,l,p,c

  n=SIZE(values)

  IF (n>50) THEN
    !median of 3 pivot
    c=n/2+1
    IF (keys(c) < keys(1)) THEN
      CALL swap_long(keys,c,1)
      CALL swap_int(values,c,1)
    ENDIF
    IF (keys(n) < keys(1)) THEN
      CALL swap_long(keys,1,n)
      CALL swap_int(values,1,n)
    ENDIF
    IF (keys(n) < keys(c)) THEN
      CALL swap_long(keys,c,n)
      CALL swap_int(values,c,n)
    ENDIF
    p=c
    CALL partition_array_qsort_1DLong_1DInt(keys,values,p,l)
    CALL qsort_1DLong_1DInt(keys(1:l-1),values(1:l-1))
    CALL qsort_1DLong_1DInt(keys(l+1:n),values(l+1:n))
  ELSE
    CALL insert_sort_1DLong_1DInt(keys,values)
  ENDIF
ENDSUBROUTINE qsort_1DLong_1DInt
!
!-------------------------------------------------------------------------------
!> @brief Partition method 1D integer key array and associated 1D int
!>         array. For a given partion, sorts values greater than and less than
!>         the partition
!> @param keys 1D integer array, modified in place and returned partioned
!> @param values 1D int array, modified in place and returned partioned
!> @param p Index of array element to partition with
!> @param i Index of the partition element once A is partitioned
!>
PURE SUBROUTINE partition_array_qsort_1DLong_1DInt(keys,values,p,i)
  INTEGER(SLK),INTENT(INOUT) :: keys(:)
  INTEGER(SIK),INTENT(INOUT) :: values(:)
  INTEGER(SIK),INTENT(IN) :: p
  INTEGER(SIK),INTENT(OUT) :: i

  INTEGER(SIK) :: j,n
  INTEGER(SLK) :: pval

  pval=keys(p)
  n=SIZE(values)
  IF (p>1) THEN
    ! if Mo3 sort, 1st element is smaller than pivot, don't throw away
    CALL swap_long(keys,1,2)
    CALL swap_int(values,1,2)
    CALL swap_long(keys,1,p)
    CALL swap_int(values,1,p)
  ENDIF

  i=2
  DO j=2,n
    IF (keys(j)<pval) THEN
      CALL swap_long(keys,i,j)
      CALL swap_int(values,i,j)
      i=i+1
    ENDIF
  ENDDO
  i=i-1
  CALL swap_long(keys,1,i)
  CALL swap_int(values,1,i)
ENDSUBROUTINE partition_array_qsort_1DLong_1DInt
!
!-------------------------------------------------------------------------------
!> @brief Swap location of 2 locations in 1D integer array.
!> @param A 1D integer array, modified in place and returned partioned
!> @param i Index of location 1
!> @param j Index of location 2
!>

PURE SUBROUTINE swap_int(A,i,j)
  INTEGER(SIK),INTENT(INOUT) :: A(:)
  INTEGER(SIK),INTENT(IN) :: i
  INTEGER(SIK),INTENT(IN) :: j
  INTEGER(SIK) :: tmp
  tmp=A(i)
  A(i)=A(j)
  A(j)=tmp
ENDSUBROUTINE swap_int
!
!-------------------------------------------------------------------------------
!> @brief Swap location of 2 locations in 1D long integer array.
!> @param A 1D integer array, modified in place and returned partioned
!> @param i Index of location 1
!> @param j Index of location 2
!>

PURE SUBROUTINE swap_long(A,i,j)
  INTEGER(SLK),INTENT(INOUT) :: A(:)
  INTEGER(SIK),INTENT(IN) :: i
  INTEGER(SIK),INTENT(IN) :: j
  INTEGER(SLK) :: tmp
  tmp=A(i)
  A(i)=A(j)
  A(j)=tmp
ENDSUBROUTINE swap_long
!
!-------------------------------------------------------------------------------
!> @brief Swap location of 2 locations in 1D string array.
!> @param A 1D string array, modified in place and returned partioned
!> @param i Index of location 1
!> @param j Index of location 2
!>

PURE SUBROUTINE swap_str(A,i,j)
  TYPE(StringType),INTENT(INOUT) :: A(:)
  INTEGER(SIK),INTENT(IN) :: i
  INTEGER(SIK),INTENT(IN) :: j
  TYPE(StringType) :: tmp
  tmp=A(i)
  A(i)=A(j)
  A(j)=tmp
ENDSUBROUTINE swap_str
!
!-------------------------------------------------------------------------------
!> @brief QuickSort 1D real array
!> @param A 1D real array, modified in place and returned sorted
!>
PURE RECURSIVE SUBROUTINE qsort_1DReal(A)
  REAL(SRK),INTENT(INOUT) :: A(:)

  INTEGER(SIK) :: n,l,p,c

  n=SIZE(A)

  IF (n>50) THEN
    !median of 3 pivot
    c=n/2
    IF (A(c) < A(1)) CALL swap_real(A,c,1)
    IF (A(n) < A(1)) CALL swap_real(A,1,n)
    IF (A(n) < A(c)) CALL swap_real(A,c,n)
    p=c
   ! p=1  ! left most pivot
   ! p=FLOOR(RAND()*REAL(n,SRK),SIK)+1  ! Randomized pivot
    CALL partition_array_1DReal(A,p,l)
    CALL qsort_1DReal(A(1:l-1))
    CALL qsort_1DReal(A(l+1:n))
  ELSE
    CALL insert_sort_real(A)
  ENDIF
ENDSUBROUTINE qsort_1DReal
!
!-------------------------------------------------------------------------------
!> @brief Partition method 1D real array.  For a given partion, sorts values
!>         greater than and less than the partition
!> @param A 1D real array, modified in place and returned partioned
!> @param p Index of array element to partition with
!> @param i Index of the partition element once A is partitioned
!>
PURE SUBROUTINE partition_array_1DReal(A,p,i)
  REAL(SRK),INTENT(INOUT) :: A(:)
  INTEGER(SIK),INTENT(IN) :: p
  INTEGER(SIK),INTENT(OUT) :: i

  INTEGER(SIK) :: j,n
  REAL(SRK) :: pval

  pval=A(p)
  n=SIZE(A)
  IF (p>1) THEN
    ! if Mo3 sort, 1st element is smaller than pivot, don't throw away
    CALL swap_real(A,1,2)
    CALL swap_real(A,1,p)
  ENDIF

  i=2
  DO j=2,n
    IF (A(j)<pval) THEN
      CALL swap_real(A,i,j)
      i=i+1
    ENDIF
  ENDDO
  i=i-1
  CALL swap_real(A,1,i)
ENDSUBROUTINE partition_array_1DReal
!
!-------------------------------------------------------------------------------
!> @brief Swap location of 2 locations in 1D real array.
!> @param A 1D real array, modified in place and returned partioned
!> @param i Index of location 1
!> @param j Index of location 2
!>

PURE SUBROUTINE swap_real(A,i,j)
  REAL(SRK),INTENT(INOUT) :: A(:)
  INTEGER(SIK),INTENT(IN) :: i
  INTEGER(SIK),INTENT(IN) :: j
  REAL(SRK) :: tmp
  tmp=A(i)
  A(i)=A(j)
  A(j)=tmp
ENDSUBROUTINE swap_real
!
ENDMODULE Sorting


MODULE InitializationModule

  USE KindModule, ONLY: &
    DP, Zero, Third, Half, One, Three, &
    Pi, TwoPi, FourPi
  USE ProgramHeaderModule, ONLY: &
    ProgramName, &
    nX, nNodesX, &
    nE, nNodesE, &
    nDOF
  USE ReferenceElementModule, ONLY: &
    NodeNumberTable1D3D
  USE MeshModule, ONLY: &
    MeshX, &
    NodeCoordinate
  USE RadiationFieldsModule, ONLY: &
    nSpecies, &
    uCR, iCR_N, iCR_G1, iCR_G2, iCR_G3

  IMPLICIT NONE
  PRIVATE

  PUBLIC :: InitializeSineWaveDiffusion1D
  PUBLIC :: InitializeSineWaveDamping1D

CONTAINS

  SUBROUTINE InitializeSineWaveDiffusion1D

    INTEGER  :: iS, iX1, iX2, iX3, iE
    INTEGER  :: iNodeX1, iNode
    REAL(DP) :: Kappa, X1

    WRITE(*,*)
    WRITE(*,'(A2,A6,A)') &
      '', 'INFO: ', TRIM( ProgramName )
    WRITE(*,*)

    Kappa = 1.0d2

    DO iS = 1, nSpecies

      DO iX3 = 1, nX(3)
        DO iX2 = 1, nX(2)
          DO iX1 = 1, nX(1)
            DO iE = 1, nE

              DO iNode = 1, nDOF

                iNodeX1 = NodeNumberTable1D3D(2,iNode)
                X1      = NodeCoordinate( MeshX(1), iX1, iNodeX1 )

                uCR(iNode,iE,iX1,iX2,iX3,iCR_N,iS) &
                  = Three * SQRT( FourPi ) &
                    * ( SIN( Third * Pi * X1 ) + One )

                uCR(iNode,iE,iX1,iX2,iX3,iCR_G1,iS) &
                  = - ( Pi * SQRT( FourPi ) / ( Three * Kappa ) ) &
                    * COS( Third * Pi * X1 )

                uCR(iNode,iE,iX1,iX2,iX3,iCR_G2,iS) &
                  = Zero

                uCR(iNode,iE,iX1,iX2,iX3,iCR_G3,iS) &
                  = Zero

              END DO

            END DO
          END DO
        END DO
      END DO

    END DO

  END SUBROUTINE InitializeSineWaveDiffusion1D

  SUBROUTINE InitializeSineWaveDamping1D

    INTEGER  :: iS, iX1, iX2, iX3, iE
    INTEGER  :: iNodeX1, iNode
    REAL(DP) :: X1

    WRITE(*,*)
    WRITE(*,'(A2,A6,A)') &
      '', 'INFO: ', TRIM( ProgramName )
    WRITE(*,*)

    DO iS = 1, nSpecies

      DO iX3 = 1, nX(3)
        DO iX2 = 1, nX(2)
          DO iX1 = 1, nX(1)
            DO iE = 1, nE

              DO iNode = 1, nDOF

                iNodeX1 = NodeNumberTable1D3D(2,iNode)
                X1      = NodeCoordinate( MeshX(1), iX1, iNodeX1 )

                uCR(iNode,iE,iX1,iX2,iX3,iCR_N,iS) &
                  = One + Half * SIN( TwoPi * X1 )

                uCR(iNode,iE,iX1,iX2,iX3,iCR_G1,iS) &
                  = uCR(iNode,iE,iX1,iX2,iX3,iCR_N,iS)

                uCR(iNode,iE,iX1,iX2,iX3,iCR_G2,iS) &
                  = Zero

                uCR(iNode,iE,iX1,iX2,iX3,iCR_G3,iS) &
                  = Zero

              END DO

            END DO
          END DO
        END DO
      END DO

    END DO

  END SUBROUTINE InitializeSineWaveDamping1D

END MODULE InitializationModule


C File: arrays-sect-22.f
C Illustrates array slicing

      program main
      implicit none

      integer, dimension (5,-2:2) :: A
      integer, dimension (5) :: B = (/-95,1,-23,45,3/)
      integer :: i, j

      A = -1

      do i = 1, 5
          write (*,10) A(i,-2), A(i,-1), A(i,0), A(i,1), A(i,2)
      end do
      write(*,11)

 10   format(5(I5,X))
 11   format('')

C      Modifying elements in two slices of A
       A(B(2::3), ::2) = 555	! A(1,-2)  A(1,0)  A(1,2), A(3,-2), A(3,0), A(3,2)

       do i = 1, 5
          write (*,10) A(i,-2), A(i,-1), A(i,0), A(i,1), A(i,2)
      end do

      stop
      end program main


subroutine sum_reduce(a, s, t)
real, intent(in) :: a(:)
real, intent(out) :: s, t
integer :: N, i
N = size(a)
s = 0
t = 0
do concurrent (i = 1:N) reduce(+:s,t)
    s = s + a(i)
    t = t + a(i)
end do
end subroutine


! { dg-do run }
! { dg-options "-ffrontend-optimize -fdump-tree-original" }
! PR 57071 - Check that (-1)**k is transformed into 1-2*iand(k,1).
program main
  implicit none
  integer, parameter :: n = 3
  integer(kind=8), dimension(-n:n) :: a, b
  integer, dimension(-n:n) :: c, d, e
  integer :: m
  integer :: i, v
  integer (kind=2) :: i2

  m = n
  v = -1
  ! Test in scalar expressions
  do i=-n,n
     if (v**i /= (-1)**i) call abort
  end do

  ! Test in array constructors
  a(-m:m) = [ ((-1)**i, i= -m, m) ]
  b(-m:m) = [ (   v**i, i= -m, m) ]
  if (any(a .ne. b)) call abort

  ! Test in array expressions
  c = [ ( i, i = -n , n ) ]
  d = (-1)**c
  e = v**c
  if (any(d .ne. e)) call abort

  ! Test in different kind expressions
  do i2=-n,n
     if (v**i2 /= (-1)**i2) call abort
  end do

end program main
! { dg-final { scan-tree-dump-times "_gfortran_pow_i4_i4" 4 "original" } }


function dv_mod_2d(x,y,z,ips)
common/mod_2d/xmod1,nxmod,dxmod,ymod1,nymod,dymod, dv_mod(2,300,300,300)

dv_mod_2d=0
if(nxmod.eq.0) return

xmod2=xmod1+dxmod*nxmod
ymod2=ymod1+dymod*nymod
zmod2=zmod1+dzmod*nzmod

if((x-xmod1)*(x-xmod2).gt.0.) return
if((y-ymod1)*(y-ymod2).gt.0.) return
if((z-zmod1)*(z-zmod2).gt.0.) return

do ix=1,nxmod-1
	x1=xmod1+(ix-1)*dxmod
	x2=xmod1+(ix)*dxmod
	if((x-x1)*(x-x2).le.0.) exit
end do

do iy=1,nymod-1
	y1=ymod1+(iy-1)*dymod
	y2=ymod1+(iy)*dymod
	if((y-y1)*(y-y2).le.0.) exit
end do

do iz=1,nzmod-1
	z1=zmod1+(iz-1)*dzmod
	z2=zmod1+(iz)*dzmod
	if((z-z1)*(z-z2).le.0.) exit
end do

v111=dv_mod(ips,ix,iy,iz)
v211=dv_mod(ips,ix+1,iy,iz)
v121=dv_mod(ips,ix,iy+1,iz)
v221=dv_mod(ips,ix+1,iy+1,iz)

v112=dv_mod(ips,ix,iy,iz+1)
v212=dv_mod(ips,ix+1,iy,iz+1)
v122=dv_mod(ips,ix,iy+1,iz+1)
v222=dv_mod(ips,ix+1,iy+1,iz+1)

v11=v111+((v211-v111)/(x2-x1))*(x-x1)
v21=v121+((v221-v121)/(x2-x1))*(x-x1)
v12=v112+((v212-v112)/(x2-x1))*(x-x1)
v22=v122+((v222-v122)/(x2-x1))*(x-x1)

v1=v11+((v21-v11)/(y2-y1))*(y-y1)
v2=v12+((v22-v12)/(y2-y1))*(y-y1)

dv_mod_2d = v1+((v2-v1)/(z2-z1))*(z-z1)

return
end