      function dasum ( n, dx, incx )

c*********************************************************************72
c
cc DASUM takes the sum of the absolute values.
c
c  Discussion:
c
c    This routine uses double precision real arithmetic.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    18 December 2008
c
c  Author:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision X(*), the vector to be examined.
c
c    Input, integer INCX, the increment between successive entries of X.
c    INCX must not be negative.
c
c    Output, double precision DASUM, the sum of the absolute values of X.
c
      implicit none

      double precision dasum
      double precision dtemp
      double precision dx(*)
      integer i
      integer incx
      integer m
      integer n
      integer nincx

      dasum = 0.0D+00
      dtemp = 0.0D+00

      if ( n .le. 0 ) then
        return
      end if

      if ( incx .le. 0 ) then
        return
      end if

      if ( incx .ne. 1 ) then

        nincx = n * incx
        do i = 1, nincx, incx
          dtemp = dtemp + dabs ( dx(i) )
        end do

      else

        m = mod ( n, 6 )

        do i = 1, m
          dtemp = dtemp + dabs ( dx(i) )
        end do

        do i = m + 1, n, 6
          dtemp = dtemp
     &      + dabs ( dx(i) )
     &      + dabs ( dx(i+1) )
     &      + dabs ( dx(i+2) )
     &      + dabs ( dx(i+3) )
     &      + dabs ( dx(i+4) )
     &      + dabs ( dx(i+5) )
        end do

      end if

      dasum = dtemp

      return
      end
      subroutine daxpy ( n, da, dx, incx, dy, incy )

c*********************************************************************72
c
cc DAXPY computes constant times a vector plus a vector.
c
c  Discussion:
c
c    This routine uses double precision real arithmetic.
c
c    This routine uses unrolled loops for increments equal to one.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    18 December 2008
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of elements in DX and DY.
c
c    Input, double precision DA, the multiplier of DX.
c
c    Input, double precision DX(*), the first vector.
c
c    Input, integer INCX, the increment between successive entries of DX.
c
c    Input/output, double precision DY(*), the second vector.
c    On output, DY(*) has been replaced by DY(*) + DA * DX(*).
c
c    Input, integer INCY, the increment between successive entries of DY.
c
      implicit none

      double precision da
      double precision dx(*)
      double precision dy(*)
      integer i
      integer incx
      integer incy
      integer ix
      integer iy
      integer m
      integer n

      if ( n .le. 0 ) then
        return
      end if

      if ( da .eq. 0.0d0 ) then
        return
      end if

      if ( incx .ne. 1 .or. incy .ne. 1 ) then

        ix = 1
        iy = 1
        if ( incx .lt. 0 ) then
          ix = (-n+1) * incx + 1
        end if

        if ( incy .lt. 0 ) then
          iy = (-n+1) * incy + 1
        end if

        do i = 1, n
          dy(iy) = dy(iy) + da * dx(ix)
          ix = ix + incx
          iy = iy + incy
        end do

      else

        m = mod ( n, 4 )

        do i = 1, m
          dy(i) = dy(i) + da * dx(i)
        end do

        do i = m + 1, n, 4
          dy(i) = dy(i) + da * dx(i)
          dy(i + 1) = dy(i + 1) + da * dx(i + 1)
          dy(i + 2) = dy(i + 2) + da * dx(i + 2)
          dy(i + 3) = dy(i + 3) + da * dx(i + 3)
        end do

      end if

      return
      end
      subroutine dcopy ( n, dx, incx, dy, incy )

c*********************************************************************72
c
cc DCOPY copies a vector.
c
c  Discussion:
c
c    This routine uses double precision real arithmetic.
c
c    The routine uses unrolled loops for increments equal to one.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of elements in DX and DY.
c
c    Input, double precision DX(*), the first vector.
c
c    Input, integer INCX, the increment between successive entries of DX.
c
c    Output, double precision DY(*), the second vector.
c
c    Input, integer INCY, the increment between successive entries of DY.
c
      implicit none

      double precision dx(*)
      double precision dy(*)
      integer i
      integer incx
      integer incy
      integer ix
      integer iy
      integer m
      integer n

      if ( n .le. 0 ) then
        return
      end if

      if ( incx .ne. 1 .or. incy .ne. 1 ) then

        ix = 1
        iy = 1
        if(incx.lt.0)ix = (-n+1)*incx + 1
        if(incy.lt.0)iy = (-n+1)*incy + 1
        do i = 1, n
          dy(iy) = dx(ix)
          ix = ix + incx
          iy = iy + incy
        end do

      else

        m = mod(n,7)

        do i = 1,m
          dy(i) = dx(i)
        end do

        do i = m + 1, n, 7
          dy(i) = dx(i)
          dy(i + 1) = dx(i + 1)
          dy(i + 2) = dx(i + 2)
          dy(i + 3) = dx(i + 3)
          dy(i + 4) = dx(i + 4)
          dy(i + 5) = dx(i + 5)
          dy(i + 6) = dx(i + 6)
        end do

      end if

      return
      end
      function ddot ( n, dx, incx, dy, incy )

c*********************************************************************72
c
cc DDOT forms the dot product of two vectors.
c
c  Discussion:
c
c    This routine uses double precision real arithmetic.
c
c    This routine uses unrolled loops for increments equal to one.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    09 February 2014
c
c  Author:
c
c    Original FORTRAN77 version by Jack Dongarra.
c    This version by John Burkardt
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vectors.
c
c    Input, double precision DX(*), the first vector.
c
c    Input, integer INCX, the increment between successive entries in DX.
c
c    Input, double precision DY(*), the second vector.
c
c    Input, integer INCY, the increment between successive entries in DY.
c
c    Output, double precision DDOT, the sum of the product of the
c    corresponding entries of DX and DY.
c
      implicit none

      double precision ddot
      double precision dx(*)
      double precision dy(*)
      double precision dtemp
      integer i
      integer incx
      integer incy
      integer ix
      integer iy
      integer m
      integer n

      ddot = 0.0D+00
      dtemp = 0.0D+00

      if ( n .le. 0 ) then
        return
      end if

      if ( incx .eq. 1 .and. incy .eq. 1 ) then

        m = mod ( n, 5 )

        do i = 1, m
          dtemp = dtemp + dx(i) * dy(i)
        end do

        do i = m + 1, n, 5
          dtemp = dtemp
     &      + dx(i)   * dy(i)
     &      + dx(i+1) * dy(i+1)
     &      + dx(i+2) * dy(i+2)
     &      + dx(i+3) * dy(i+3)
     &      + dx(i+4) * dy(i+4)
        end do
c
c  Code for unequal increments or equal increments not equal to 1
c
      else

        if ( incx .lt. 0 ) then
          ix = ( - n + 1 ) * incx + 1
        else
          ix = 1
        end if

        if ( incy .lt. 0 ) then
          iy = ( - n + 1 ) * incy + 1
        else
          iy = 1
        end if

        do i = 1, n
          dtemp = dtemp + dx(ix) * dy(iy)
          ix = ix + incx
          iy = iy + incy
        end do

      end if

      ddot = dtemp

      return
      end
      function dnrm2 ( n, x, incx )

c*********************************************************************72
c
cc DNRM2 returns the euclidean norm of a vector.
c
c  Discussion:
c
c    This routine uses double precision real arithmetic.
c
c      DNRM2 ( X ) = sqrt ( X' * X )
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    09 February 2014
c
c  Author:
c
c    Sven Hammarling
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision X(*), the vector whose norm is to be computed.
c
c    Input, integer INCX, the increment between successive entries of X.
c
c    Output, double precision DNRM2, the Euclidean norm of X.
c
      implicit none

      integer incx, n

      double precision dnrm2
      double precision x( * )

      double precision one         , zero
      parameter ( one = 1.0d+0, zero = 0.0d+0 )

      integer ix
      double precision absxi, norm, scale, ssq

      intrinsic abs, sqrt

      if( n.lt.1 .or. incx.lt.1 )then
         norm  = zero
      else if( n.eq.1 )then
         norm  = abs( x( 1 ) )
      else
         scale = zero
         ssq   = one
c
c  The following loop is equivalent to this call to the LAPACK
c  auxiliary routine:
c  call dlassq( n, x, incx, scale, ssq )
c
         do ix = 1, 1 + ( n - 1 )*incx, incx
            if( x( ix ).ne.zero )then
               absxi = abs( x( ix ) )
               if( scale.lt.absxi )then
                  ssq   = one   + ssq*( scale/absxi )**2
                  scale = absxi
               else
                  ssq   = ssq   +     ( absxi/scale )**2
               end if
            end if
         end do
         norm  = scale * sqrt( ssq )
      end if

      dnrm2 = norm

      return
      end
      subroutine drot ( n, dx, incx, dy, incy, c, s )

c*********************************************************************72
c
cc DROT applies a plane rotation.
c
c  Discussion:
c
c    This routine uses double precision real arithmetic.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vectors.
c
c    Input/output, double precision X(*), one of the vectors to be rotated.
c
c    Input, integer INCX, the increment between successive entries of X.
c
c    Input/output, double precision Y(*), one of the vectors to be rotated.
c
c    Input, integer INCY, the increment between successive elements of Y.
c
c    Input, double precision C, S, parameters (presumably the cosine and
c    sine of some angle) that define a plane rotation.
c
      implicit none

      double precision c
      double precision dtemp
      double precision dx(*)
      double precision dy(*)
      double precision s
      integer i,incx,incy,ix,iy,n

      if ( n .le. 0 ) then
        return
      end if

      if(incx.eq.1.and.incy.eq.1)go to 20
c
c  code for unequal increments or equal increments not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0) then
        ix = (-n+1)*incx + 1
      end if

      if(incy.lt.0) then
        iy = (-n+1)*incy + 1
      end if

      do i = 1,n
        dtemp = c*dx(ix) + s*dy(iy)
        dy(iy) = c*dy(iy) - s*dx(ix)
        dx(ix) = dtemp
        ix = ix + incx
        iy = iy + incy
      end do
      return
c
c  code for both increments equal to 1
c
   20 do i = 1,n
        dtemp = c*dx(i) + s*dy(i)
        dy(i) = c*dy(i) - s*dx(i)
        dx(i) = dtemp
      end do

      return
      end
      subroutine drotg ( da, db, c, s )

c*********************************************************************72
c
cc DROTG constructs a Givens plane rotation.
c
c  Discussion:
c
c    This routine uses double precision real arithmetic.
c
c    Given values A and B, this routine computes
c
c    SIGMA = sign ( A ) if abs ( A ) >  abs ( B )
c          = sign ( B ) if abs ( A ) <= abs ( B );
c
c    R     = SIGMA * ( A * A + B * B );
c
c    C = A / R if R is not 0
c      = 1     if R is 0;
c
c    S = B / R if R is not 0,
c        0     if R is 0.
c
c    The computed numbers then satisfy the equation
c
c    (  C  S ) ( A ) = ( R )
c    ( -S  C ) ( B ) = ( 0 )
c
c    The routine also computes
c
c    Z = S     if abs ( A ) > abs ( B ),
c      = 1 / C if abs ( A ) <= abs ( B ) and C is not 0,
c      = 1     if C is 0.
c
c    The single value Z encodes C and S, and hence the rotation:
c
c    If Z = 1, set C = 0 and S = 1;
c    If abs ( Z ) < 1, set C = sqrt ( 1 - Z * Z ) and S = Z;
c    if abs ( Z ) > 1, set C = 1/ Z and S = sqrt ( 1 - C * C );
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input/output, double precision SA, SB.  On input, SA and SB are the values
c    A and B.  On output, SA is overwritten with R, and SB is
c    overwritten with Z.
c
c    Output, double precision C, S, the cosine and sine of the
c    Givens rotation.
c
      implicit none

      double precision c
      double precision da
      double precision db,s,roe,scale,r,z

      roe = db
      if( dabs(da) .gt. dabs(db) ) roe = da
      scale = dabs(da) + dabs(db)

      if( scale .eq. 0.0d0 ) then
         c = 1.0d0
         s = 0.0d0
         r = 0.0d0
         z = 0.0d0
      else
        r = scale*dsqrt((da/scale)**2 + (db/scale)**2)
        r = dsign(1.0d0,roe)*r
        c = da/r
        s = db/r
        z = 1.0d0
        if( dabs(da) .gt. dabs(db) ) z = s
        if( dabs(db) .ge. dabs(da) .and. c .ne. 0.0d0 ) z = 1.0d0/c
      end if

      da = r
      db = z

      return
      end
      subroutine drotm ( n, dx, incx, dy, incy, dparam )

c*********************************************************************72
c
cc DROTM applies a modified Givens rotation matrix.
c
c  Purpose
c  =======
c
c     APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX
c
c     (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN
c     (DY**T)
c
c     DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
c     LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY.
c     WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
c
c     DFLAG=-1.D0     DFLAG=0.D0        DFLAG=1.D0     DFLAG=-2.D0
c
c       (DH11  DH12)    (1.D0  DH12)    (DH11  1.D0)    (1.D0  0.D0)
c     H=(          )    (          )    (          )    (          )
c       (DH21  DH22),   (DH21  1.D0),   (-1.D0 DH22),   (0.D0  1.D0).
c     SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    09 February 2014
c
c  Author:
c
c    Original FORTRAN77 version by Jack Dongarra.
c    This version by John Burkardt
c
c  Arguments
c  =========
c
c  N      (input) INTEGER
c         number of elements in input vector(s)
c
c  DX     (input/output) DOUBLE PRECISION array, dimension N
c         double precision vector with N elements
c
c  INCX   (input) INTEGER
c         storage spacing between elements of DX
c
c  DY     (input/output) DOUBLE PRECISION array, dimension N
c         double precision vector with N elements
c
c  INCY   (input) INTEGER
c         storage spacing between elements of DY
c
c  DPARAM (input/output)  DOUBLE PRECISION array, dimension 5
c     DPARAM(1)=DFLAG
c     DPARAM(2)=DH11
c     DPARAM(3)=DH21
c     DPARAM(4)=DH12
c     DPARAM(5)=DH22
c
      integer incx,incy,n

      double precision dparam(5),dx(*),dy(*)
      double precision dflag,dh11,dh12,dh21,dh22,two,w,z,zero
      integer i,kx,ky,nsteps

      data zero,two/0.d0,2.d0/

      dflag = dparam(1)
      if (n.le.0 .or. (dflag+two.eq.zero)) return
      if (incx.eq.incy.and.incx.gt.0) then

         nsteps = n*incx
         if (dflag.lt.zero) then
            dh11 = dparam(2)
            dh12 = dparam(4)
            dh21 = dparam(3)
            dh22 = dparam(5)
            do i = 1,nsteps,incx
               w = dx(i)
               z = dy(i)
               dx(i) = w*dh11 + z*dh12
               dy(i) = w*dh21 + z*dh22
            end do
         else if (dflag.eq.zero) then
            dh12 = dparam(4)
            dh21 = dparam(3)
            do i = 1,nsteps,incx
               w = dx(i)
               z = dy(i)
               dx(i) = w + z*dh12
               dy(i) = w*dh21 + z
            end do
         else
            dh11 = dparam(2)
            dh22 = dparam(5)
            do i = 1,nsteps,incx
               w = dx(i)
               z = dy(i)
               dx(i) = w*dh11 + z
               dy(i) = -w + dh22*z
            end do
         end if
      else
         kx = 1
         ky = 1
         if (incx.lt.0) kx = 1 + (1-n)*incx
         if (incy.lt.0) ky = 1 + (1-n)*incy
*
         if (dflag.lt.zero) then
            dh11 = dparam(2)
            dh12 = dparam(4)
            dh21 = dparam(3)
            dh22 = dparam(5)
            do i = 1,n
               w = dx(kx)
               z = dy(ky)
               dx(kx) = w*dh11 + z*dh12
               dy(ky) = w*dh21 + z*dh22
               kx = kx + incx
               ky = ky + incy
            end do
         else if (dflag.eq.zero) then
            dh12 = dparam(4)
            dh21 = dparam(3)
            do i = 1,n
               w = dx(kx)
               z = dy(ky)
               dx(kx) = w + z*dh12
               dy(ky) = w*dh21 + z
               kx = kx + incx
               ky = ky + incy
            end do
         else
             dh11 = dparam(2)
             dh22 = dparam(5)
             do i = 1,n
                w = dx(kx)
                z = dy(ky)
                dx(kx) = w*dh11 + z
                dy(ky) = -w + dh22*z
                kx = kx + incx
                ky = ky + incy
            end do
         end if
      end if
      return
      end
      subroutine drotmg(dd1,dd2,dx1,dy1,dparam)

c*********************************************************************72
c
cc DROTMG generates a modified Givens rotation matrix.
c
*  Purpose
*  =======
*
*     CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
*     THE SECOND COMPONENT OF THE 2-VECTOR  (DSQRT(DD1)*DX1,DSQRT(DD2)*
*     DY2)**T.
*     WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
*
*     DFLAG=-1.D0     DFLAG=0.D0        DFLAG=1.D0     DFLAG=-2.D0
*
*       (DH11  DH12)    (1.D0  DH12)    (DH11  1.D0)    (1.D0  0.D0)
*     H=(          )    (          )    (          )    (          )
*       (DH21  DH22),   (DH21  1.D0),   (-1.D0 DH22),   (0.D0  1.D0).
*     LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
*     RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
*     VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
*
*     THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
*     INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
*     OF DD1 AND DD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
*
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    09 February 2014
c
*  Arguments
*  =========
*
*  DD1    (input/output) DOUBLE PRECISION
*
*  DD2    (input/output) DOUBLE PRECISION
*
*  DX1    (input/output) DOUBLE PRECISION
*
*  DY1    (input) DOUBLE PRECISION
*
*  DPARAM (input/output)  DOUBLE PRECISION array, dimension 5
*     DPARAM(1)=DFLAG
*     DPARAM(2)=DH11
*     DPARAM(3)=DH21
*     DPARAM(4)=DH12
*     DPARAM(5)=DH22
*
      double precision dd1,dd2,dx1,dy1
      double precision dparam(5)
      double precision dflag,dh11,dh12,dh21,dh22,dp1,dp2,dq1,dq2,dtemp,
     $                 du,gam,gamsq,one,rgamsq,two,zero
*     ..
*     .. intrinsic functions ..
      intrinsic dabs
*     ..
*     .. data statements ..
*
      data zero,one,two/0.d0,1.d0,2.d0/
      data gam,gamsq,rgamsq/4096.d0,16777216.d0,5.9604645d-8/
*     ..

      if (dd1.lt.zero) then
*        go zero-h-d-and-dx1..
         dflag = -one
         dh11 = zero
         dh12 = zero
         dh21 = zero
         dh22 = zero
         dd1 = zero
         dd2 = zero
         dx1 = zero
      else
*        case-dd1-nonnegative
         dp2 = dd2*dy1
         if (dp2.eq.zero) then
            dflag = -two
            dparam(1) = dflag
            return
         end if
*        regular-case..
         dp1 = dd1*dx1
         dq2 = dp2*dy1
         dq1 = dp1*dx1
*
         if (dabs(dq1).gt.dabs(dq2)) then
            dh21 = -dy1/dx1
            dh12 = dp2/dp1
*
            du = one - dh12*dh21
*
           if (du.gt.zero) then
             dflag = zero
             dd1 = dd1/du
             dd2 = dd2/du
             dx1 = dx1*du
           end if
         else

            if (dq2.lt.zero) then
*              go zero-h-d-and-dx1..
               dflag = -one
               dh11 = zero
               dh12 = zero
               dh21 = zero
               dh22 = zero
*
               dd1 = zero
               dd2 = zero
               dx1 = zero
            else
               dflag = one
               dh11 = dp1/dp2
               dh22 = dx1/dy1
               du = one + dh11*dh22
               dtemp = dd2/du
               dd2 = dd1/du
               dd1 = dtemp
               dx1 = dy1*du
            end if
         end if

*     procedure..scale-check
         if (dd1.ne.zero) then
            do while ((dd1.le.rgamsq) .or. (dd1.ge.gamsq))
               if (dflag.eq.zero) then
                  dh11 = one
                  dh22 = one
                  dflag = -one
               else
                  dh21 = -one
                  dh12 = one
                  dflag = -one
               end if
               if (dd1.le.rgamsq) then
                  dd1 = dd1*gam**2
                  dx1 = dx1/gam
                  dh11 = dh11/gam
                  dh12 = dh12/gam
               else
                  dd1 = dd1/gam**2
                  dx1 = dx1*gam
                  dh11 = dh11*gam
                  dh12 = dh12*gam
               end if
            enddo
         end if

         if (dd2.ne.zero) then
            do while ( (dabs(dd2).le.rgamsq) .or. (dabs(dd2).ge.gamsq) )
               if (dflag.eq.zero) then
                  dh11 = one
                  dh22 = one
                  dflag = -one
               else
                  dh21 = -one
                  dh12 = one
                  dflag = -one
               end if
               if (dabs(dd2).le.rgamsq) then
                  dd2 = dd2*gam**2
                  dh21 = dh21/gam
                  dh22 = dh22/gam
               else
                  dd2 = dd2/gam**2
                  dh21 = dh21*gam
                  dh22 = dh22*gam
               end if
            end do
         end if

      end if

      if (dflag.lt.zero) then
         dparam(2) = dh11
         dparam(3) = dh21
         dparam(4) = dh12
         dparam(5) = dh22
      else if (dflag.eq.zero) then
         dparam(3) = dh21
         dparam(4) = dh12
      else
         dparam(2) = dh11
         dparam(5) = dh22
      end if

      dparam(1) = dflag

      return
      end
      subroutine dscal ( n, da, dx, incx )

c*********************************************************************72
c
cc DSCAL scales a vector by a constant.
c
c  Discussion:
c
c    This routine uses double precision real arithmetic.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    09 February 2014
c
c  Author:
c
c    Original FORTRAN77 version by Jack Dongarra.
c    This version by John Burkardt.
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision SA, the multiplier.
c
c    Input/output, double precision X(*), the vector to be scaled.
c
c    Input, integer INCX, the increment between successive entries of X.
c
      implicit none

      double precision da
      double precision dx(*)
      integer i
      integer incx
      integer m
      integer n
      integer nincx

      if ( n .le. 0 ) then
        return
      end if

      if ( incx .le. 0 ) then
        return
      end if

      if ( incx .eq. 1 ) then

        m = mod ( n, 5 )

        do i = 1, m
          dx(i) = da * dx(i)
        end do

        do i = m + 1, n, 5
          dx(i) =     da * dx(i)
          dx(i+1) = da * dx(i+1)
          dx(i+2) = da * dx(i+2)
          dx(i+3) = da * dx(i+3)
          dx(i+4) = da * dx(i+4)
        end do

      else

        nincx = n * incx
        do i = 1, nincx, incx
          dx(i) = da * dx(i)
        end do
      end if

      return
      end
      function dsdot ( n, sx, incx, sy, incy )

c*********************************************************************72
c
cc DSDOT computes the inner product of two vectors with extended precision.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
*     ..
*
*  AUTHORS
*  =======
*  Lawson, C. L., (JPL), Hanson, R. J., (SNLA),
*  Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL)
*
*  Purpose
*  =======
*  Compute the inner product of two vectors with extended
*  precision accumulation and result.
*
*  Returns D.P. dot product accumulated in D.P., for S.P. SX and SY
*  DSDOT = sum for I = 0 to N-1 of  SX(LX+I*INCX) * SY(LY+I*INCY),
*  where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
*  defined in a similar way using INCY.
*
*  Arguments
*  =========
*
*  N      (input) INTEGER
*         number of elements in input vector(s)
*
*  SX     (input) REAL array, dimension(N)
*         single precision vector with N elements
*
*  INCX   (input) INTEGER
*          storage spacing between elements of SX
*
*  SY     (input) REAL array, dimension(N)
*         single precision vector with N elements
*
*  INCY   (input) INTEGER
*         storage spacing between elements of SY
*
*  DSDOT  (output) DOUBLE PRECISION
*         DSDOT  double precision dot product (zero if N.LE.0)
*
*  Further Details
*  ===============
*
*  REFERENCES
*
*  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
*  Krogh, Basic linear algebra subprograms for Fortran
*  usage, Algorithm No. 539, Transactions on Mathematical
*  Software 5, 3 (September 1979), pp. 308-323.
c
      double precision dsdot
      INTEGER INCX,INCY,N
      REAL SX(*),SY(*)
      integer i,kx,ky,ns

      intrinsic dble

      dsdot = 0.0d0
      if (n.le.0) return
      if (incx.eq.incy .and. incx.gt.0) then
c
c     code for equal, positive, non-unit increments.
c
         ns = n*incx
         do i = 1,ns,incx
            dsdot = dsdot + dble(sx(i))*dble(sy(i))
         end do
      else
c
c     code for unequal or nonpositive increments.
c
         kx = 1
         ky = 1
         if (incx.lt.0) kx = 1 + (1-n)*incx
         if (incy.lt.0) ky = 1 + (1-n)*incy
         do i = 1,n
            dsdot = dsdot + dble(sx(kx))*dble(sy(ky))
            kx = kx + incx
            ky = ky + incy
         end do
      end if

      return
      end
      subroutine dswap ( n, dx, incx, dy, incy )

c*********************************************************************72
c
cc DSWAP interchanges two vectors.
c
c  Discussion:
c
c    This routine uses double precision real arithmetic.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vectors.
c
c    Input/output, double precision X(*), one of the vectors to swap.
c
c    Input, integer INCX, the increment between successive entries of X.
c
c    Input/output, double precision Y(*), one of the vectors to swap.
c
c    Input, integer INCY, the increment between successive elements of Y.
c
      implicit none

      double precision dx(*),dy(*),dtemp
      integer i,incx,incy,ix,iy,m,n

      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c  code for unequal increments or equal increments not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        dtemp = dx(ix)
        dx(ix) = dy(iy)
        dy(iy) = dtemp
        ix = ix + incx
        iy = iy + incy
      end do
      return
c
c  code for both increments equal to 1
c
c
c  clean-up loop
c
   20 m = mod(n,3)
      if( m .eq. 0 ) go to 40
      do i = 1,m
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
      end do
      if( n .lt. 3 ) return
   40 continue

      do i = m+1, n, 3
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
        dtemp = dx(i + 1)
        dx(i + 1) = dy(i + 1)
        dy(i + 1) = dtemp
        dtemp = dx(i + 2)
        dx(i + 2) = dy(i + 2)
        dy(i + 2) = dtemp
      end do

      return
      end
      function idamax ( n, dx, incx )

c*********************************************************************72
c
cc IDAMAX finds the index of element having maximum absolute value.
c
c  Discussion:
c
c    This routine uses double precision real arithmetic.
c
c  Licensing:
c
c    This code is distributed under the GNU LGPL license.
c
c  Modified:
c
c    07 July 2007
c
c  Author:
c
c    Jack Dongarra
c
c  Reference:
c
c    Jack Dongarra, Jim Bunch, Cleve Moler, Pete Stewart,
c    LINPACK User's Guide,
c    SIAM, 1979,
c    ISBN13: 978-0-898711-72-1,
c    LC: QA214.L56.
c
c    Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh,
c    Basic Linear Algebra Subprograms for FORTRAN usage,
c    ACM Transactions on Mathematical Software,
c    Volume 5, Number 3, pages 308-323, 1979.
c
c  Parameters:
c
c    Input, integer N, the number of entries in the vector.
c
c    Input, double precision X(*), the vector to be examined.
c
c    Input, integer INCX, the increment between successive entries of SX.
c
c    Output, integer IDAMAX, the index of the element of SX of maximum
c    absolute value.
c
      implicit none

      double precision dmax
      double precision dx(*)
      integer i
      integer idamax
      integer incx
      integer ix
      integer n

      idamax = 0
      if ( n .lt. 1 .or. incx .le. 0 ) then
        return
      end if

      idamax = 1
      if ( n .eq. 1 ) then
        return
      end if

      if ( incx .eq. 1 ) then

        dmax = dabs ( dx(1) )
        do i = 2, n
          if( dmax .lt. dabs ( dx(i) ) ) then
            idamax = i
            dmax = dabs ( dx(i) )
          end if
        end do

      else

        ix = 1
        dmax = dabs ( dx(1) )
        ix = ix + incx
        do  i = 2, n
          if ( dmax .lt. dabs ( dx(ix) ) ) then
            idamax = i
            dmax = dabs ( dx(ix) )
          end if
          ix = ix + incx
        end do

      end if

      return
      end


c     Subroutine to find dew point from vapor pressure
c     AJ_Kettle, Nov7/2017

c     from wmo_8_en-2012.pdf

      SUBROUTINE dewp_from_vpres_stnpres(f_ew_hpa,f_p_hpa,
     +   f_dewp_c)

      IMPLICIT NONE
c************************************************************************
      REAL                :: f_dewp_c

      REAL                :: f_ew_hpa
      REAL                :: f_p_hpa

      REAL                :: f_p_coef
c************************************************************************
c     Find pressure coefficient
      f_p_coef=1.0016+3.15*10.0**(-6.0)*f_p_hpa-0.074/f_p_hpa

      f_dewp_c=(243.12*ALOG(f_ew_hpa/(6.112*f_p_coef)))/
     +   (17.62-ALOG(f_ew_hpa/(6.112*f_p_coef)))

c      f_dewp_c=(243.12*ALOG(f_ew_pa/611.2))/(17.62-ALOG(f_ew_pa/611.2))
c************************************************************************
      RETURN
      END


module ode
  !! Module for solving first order explicit ordinary differential equations, expressed in the form:
  !! \[
  !! \frac{dy}{dt}=F\left(y,t\right)\\
  !! y(0) = y_0
  !! \]
  !! where, \(y(t)\) is the unknown function, \(t\) is the independent variable and
  !! \(y_0\) is the initial condition.
      implicit none
      contains

        function forward_euler(f,t,U0) result(U)
          !! function for integrating vector first order ODEs of the form:
          !! \[
          !! \frac{d\mathbf{U}}{dt}=\mathbf{F}\left(\mathbf{U},t\right)
          !! \]
          !! using the forward (explicit) euler method.
          interface
            function f(U,t) result(dU)
            !! function \(\mathbf{F}\) of the system
              real, intent(in) :: U(:)
            !! value of the unknown function \(\mathbf{U}(t)\)
              real, intent(in) :: t
            !! independent variable \(t\)
              real :: dU(size(U))
            !! derivative of \(\mathbf{y}\)
            end function
          end interface
          real, intent(in) :: t(0:)
          !! array of times \( t_0,t_1,\dots,t_N \)where the numerical solution
          !! will be evaluated.
          real, intent(in) :: U0(:)
          !! initial conditions \(\mathbf{U}(t_0)\)
          real :: U(0:ubound(t,1),size(U0))
          !! solution array \(U_j(t_i)\) such that the
          !! the row \(i\) and column \(j\) stands for the
          !! \(j\)th component of the vector solution \(\mathbf{U}\) at time \(t_i\).
          integer :: N, i
          N = ubound(t,1)
          U(0,:) = U0
          do i=1,N
            U(i,:) = U(i-1,:) + (t(i)-t(i-1))*F(U(i-1,:),t(i-1))
          end do
        end function

end module


!  *******************************************************************
!  *                                                                 *
!  *                     Function dlspx3                             *
!  *                                                                 *
!  *******************************************************************
!  Double Precision Version 1.42
!  Written by Gordon A. Fenton, Mar. 25, 1994
!  Latest Update: Sep 21, 2001
!
!  PURPOSE  returns the covariance between two points in a 3-D random field
!           having an exponential (Gaussian) type covariance function
!           (separable and mean-square differentiable).
!
!  This function returns the covariance between two points separated
!  by lag vector {X,Y,Z}. The process has a separable and mean-square
!  differentiable covariance function,
!
!      B(X,Y,Z) = var * exp{ -pi*[(|X|/thx)^2 + (|Y|/thy)^2 + (|Z|/thz)^2] }
!
!  where var is the point variance, thx, thy, and thz are the directional
!  scales of fluctuation and (X,Y,Z) are elements of the lag vector
!  separating the two points of interest.
!
!  The parameters var, dthx, dthy, and dthz are brought into this
!  routine through the common block /dparam/.
!
!  If var < 0, then this function computes the variance of a local average
!  of the random field, averaged over a domain having side dimensions {X,Y,Z}.
!  The variance function is also separable and can be written
!  as the product of three one-d variance functions
!
!         V(X,Y,Z) = V(X)*V(Y)*V(Z)
!
!  each corresponding to the 1-D Gaussian type correlation function,
!
!         p(x) = exp{-pi*(|x|/thx)^2}
!
!  The individual variance functions are based on the 1-D analytical model
!
!         V(X) = (1/a*a) * [pi*(|X|/thx)*erf(a) + exp(-a*a) - 1]
!
!  where a = (|X|*sqrt(pi))/thx and erf(.) is the error function.
!  See page 186 of "Random Fields" by E. Vanmarcke and G.A. Fenton's thesis
!  for more details. If var < 0, this function returns |var|*V(X,Y,Z).
!
!  The arguments to this routine, X, Y, and Z, are the components of the
!  lag vector between the two points of interest (or the dimensions of the
!  averaging volume, if var < 0)
!
!  The data value `eund' is designed to avoid underflow errors arising from
!  exp(-a) for a > eund. We quite happily accept a zero in this case. This
!  tends to be compiler dependent.
!
!  Requires:
!    1) from Fortran lib: d_erf	(error function), define the following
!	r_erf(s) = d_erf(s) (on SunOS 4.1.3)
!	r_erf(s) = derf(s)  (on DEC OSF/1)
!
!  REVISION HISTORY:
!  1.1	eliminated unused local variables `two' and `four' (Dec 5/96)
!  1.2	added lvarfn flag to end of /dparam/ common block. Set it to
!	true if the variance function is to be returned. Otherwise this
!	function returns the covariance. (May 31/00)
!  1.3	eliminated lvarfn -- now return covariances only if var < 0 (Apr 9/01)
!  1.4	reversed default - now return covariances if var > 0. (Apr 11/01)
!  1.41	revised above documentation to reflect revision 1.4 (May 9/01)
!  1.42	replaced 'dthx' with 'thx' (etc) below (Sep 21/01)
!---------------------------------------------------------------------------
      real*8 function dlspx3( X, Y, Z )
      implicit real*8 (a-h,o-z)
      common/dparam/ var, pb, thx, thy, thz
      data zero/0.d0/, one/1.d0/
      data rtpi/1.77245385090551588d0/, eund/300.d0/
      data pi/3.1415926535897932384d0/
      exp(s)   = dexp(s)
      abs(s)   = dabs(s)
      r_erf(s) = derf(s)

      if( var .lt. zero ) then			! return variance of local ave
         rx = abs(X)/thx
         a  = rtpi*rx
         aa = a*a
         ry = abs(Y)/thy
         b  = rtpi*ry
         bb = b*b
         rz = abs(Z)/thz
         c  = rtpi*rz
         cc = c*c
!							in the x direction
         if( X .eq. zero ) then
            dsepa = one
         elseif( aa .lt. eund ) then
            dsepa = (pi*rx*r_erf(a) + exp(-aa) - one)/aa
         else
            dsepa = (pi*rx - one)/aa
         endif
!							in the y direction
         if( Y .eq. zero ) then
            dsepb = one
         elseif( bb .lt. eund ) then
            dsepb = (pi*ry*r_erf(b) + exp(-bb) - one)/bb
         else
            dsepb = (pi*ry - one)/bb
         endif
!							and in the z direction
         if( Z .eq. zero ) then
            dsepc = one
         elseif( cc .lt. eund ) then
            dsepc = (pi*rz*r_erf(c) + exp(-cc) - one)/cc
         else
            dsepc = (pi*rz - one)/cc
         endif
         dlspx3 = -var*dsepa*dsepb*dsepc

      else					! return covariance
!							in the x direction
         if( thx .eq. zero ) then
            if( X .eq. zero ) then
               dsepa = one
            else
               dsepa = zero
            endif
         else
            rx = X/thx
            dsepa = exp(-pi*rx*rx)
         endif
!							in the y direction
         if( thy .eq. zero ) then
            if( Y .eq. zero ) then
               dsepb = one
            else
               dsepb = zero
            endif
         else
            ry = Y/thy
            dsepb = exp(-pi*ry*ry)
         endif
!							in the y direction
         if( thz .eq. zero ) then
            if( Z .eq. zero ) then
               dsepc = one
            else
               dsepc = zero
            endif
         else
            rz = Z/thz
            dsepc = exp(-pi*rz*rz)
         endif
         dlspx3 = var*dsepa*dsepb*dsepc
      endif

      return
      end


      SUBROUTINE EARLIN(X,Y,N,V,MEG)
      DIMENSION C(11,11),V(11),X(N),Y(N),XX(11),E(11)
      M=IABS(MEG)
      MPL=M+1
      DO 10 I=1,M
      DO 10 J=1,MPL
      C(I,J)=0
10    CONTINUE
      DO 20 I=1,N
      XXX=1
      DO 20 J=1,M
      IF(J.NE.1)XXX=XXX*X(I)
      XX(J)=XXX
      C(J,M+1)=C(J,M+1)+XX(J)*Y(I)
      DO 20 K=1,J
      C(J,K)=C(J,K)+XX(J)*XX(K)
20    CONTINUE
      DO 30 J=2,M
      JMI=J-1
      DO 30 K=1,JMI
      C(K,J)=C(J,K)
30    CONTINUE
      DET=SIMUL(M,C,V,0.,0,11)
      IF(MEG.LT.0)RETURN
      DO 40 I=1,M
      E(I)=SQRT(C(I,I))
      DO 40 J=1,I
      C(I,J)=C(I,J)/(E(I)*E(J))
40    CONTINUE
C      PRINT 1000
C      PRINT 1000,(V(I),I=1,M)
C      PRINT 1000,(E(I),I=1,M)
C      PRINT 1000
C      DO 50 I=1,M
C      PRINT 1000,(C(I,J),J=1,I)
C50    CONTINUE
      RETURN
C1000  FORMAT(1H 10F12.5)
      END


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc                mnperc : percur test program                        cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real x(27),y(27),w(27),t(37),c(37),wrk(1400),sp(27)
      integer iwrk(37)
      real al,fp,s
      integer i,ier,iopt,is,j,k,l,lwrk,l1,l2,m,m1,n,nest,nk1
c  the data absciss values
      data x(1),x(2),x(3),x(4),x(5),x(6),x(7),x(8),x(9),x(10),x(11),
     * x(12),x(13),x(14),x(15),x(16),x(17),x(18),x(19),x(20),x(21),
     * x(22),x(23),x(24),x(25),x(26)/0.0,3.922,7.843,11.765,15.686,
     * 19.608,23.509,27.451,31.373,35.294,39.216,43.137,47.059,50.980,
     * 54.902,58.824,62.745,66.667,70.588,74.510,78.431,82.353,86.275,
     * 90.196,94.118,98.039/
c  the data ordinate values
      data y(1),y(2),y(3),y(4),y(5),y(6),y(7),y(8),y(9),y(10),y(11),
     * y(12),y(13),y(14),y(15),y(16),y(17),y(18),y(19),y(20),y(21),
     * y(22),y(23),y(24),y(25),y(26)/10.099,14.835,21.453,25.022,22.427,
     * 22.315,22.070,19.673,16.754,13.983,11.973,12.286,16.129,21.560,
     * 28.041,39.205,59.489,72.559,75.960,79.137,75.925,68.809,55.758,
     * 39.915,22.006,12.076/
c  m denotes the number of data points
      m = 27
c  the period of the spline is determined by x(m)
      x(m) = 100.
      y(m) = y(1)
c  we set up the weights of the data points
      m1 = m-1
      do 10 i=1,m1
         w(i) = 1.0
  10  continue
c  we set up the dimension information.
      nest = 37
      lwrk = 1400
c  loop for the different spline degrees.
      do 400 k=3,5,2
c  loop for the different spline approximations of degree k
         do 300 is=1,7
            go to (110,120,130,140,150,160,170),is
c  we start computing the least-squares constant (large value for s).
 110        iopt = 0
            s = 65000.
            go to 200
c  iopt=1 from the second call on
 120        iopt = 1
            s = 500.
            go to 200
c  a smaller value for s to get a closer approximation
 130        s = 5.
            go to 200
c  a larger value for s to get a smoother approximation
 140        s = 20.
            go to 200
c  if a satisfactory fit is obtained  we can calculate a spline of equal
c  quality of fit ( same value for s ) but possibly with fewer knots by
c  specifying iopt=0
 150        s = 20.
            iopt = 0
            go to 200
c  we calculate an interpolating periodic spline.
 160        s = 0.
            go to 200
c  finally, we also calculate a least-squares periodic spline function
c  with specified knots.
 170        iopt = -1
            n = 11+2*k
            j = k+2
            do 180 l=1,9
               al = l*10
               t(j) = al
               j = j+1
 180        continue
c  determine the periodic spline approximation
 200        call percur(iopt,m,x,y,w,k,s,nest,n,t,c,fp,wrk,lwrk,
     *       iwrk,ier)
c  printing of the results.
            if(iopt.ge.0) go to 210
            write(6,910) k
            go to 220
 210        write(6,915) k
            write(6,920) s
 220        write(6,925) fp,ier
            write(6,930) n
            write(6,935)
            write(6,940) (t(i),i=1,n)
            nk1 = n-k-1
            write(6,945)
            write(6,950) (c(i),i=1,nk1)
            write(6,955)
c  evaluation of the spline approximation
            call splev(t,n,c,k,x,sp,m,ier)
            do 230 i=1,9
               l1 = (i-1)*3+1
               l2 = l1+2
               write(6,960) (x(l),y(l),sp(l),l=l1,l2)
 230        continue
 300     continue
 400  continue
      stop
 910  format(41h0least-squares periodic spline of degree ,i1)
 915  format(37h0smoothing periodic spline of degree ,i1)
 920  format(20h smoothing factor s=,f7.0)
 925  format(1x,23hsum squared residuals =,e15.6,5x,11herror flag=,i2)
 930  format(1x,24htotal number of knots n=,i3)
 935  format(1x,22hposition of the knots )
 940  format(5x,8f8.3)
 945  format(23h0b-spline coefficients )
 950  format(5x,8f8.4)
 955  format(1h0,3(3x,2hxi,6x,2hyi,4x,5hs(xi),3x))
 960  format(1h ,3(f7.3,1x,f7.3,1x,f7.3,2x))
      end


************************************************************************
*
*     Function CORR                  Called by: AMLSTAT, OUTEQN
*
*     compute correlation between two variables
*
************************************************************************
      DOUBLE PRECISION FUNCTION CORR(N,X,Y)
*
*     function args
*
      INTEGER*4 N
      DOUBLE PRECISION X(*),Y(*)
*
*     local vars
*
      INTEGER*4 I
      DOUBLE PRECISION C1,MX,MY,SX,SY
*
*
*
      MX = 0.D0
      MY = 0.D0

      DO 10 I=1,N
        MX = MX+X(I)
        MY = MY+Y(I)
   10 CONTINUE

      MX = MX/DBLE(N)
      MY = MY/DBLE(N)
      C1 = 0.D0
      SX = 0.D0
      SY = 0.D0

      DO 20 I=1,N
        C1 = C1+(X(I)-MX)*(Y(I)-MY)
        SX = SX+(X(I)-MX)**2
        SY = SY+(Y(I)-MY)**2
   20 CONTINUE

      CORR = C1/SQRT(MAX(1.D-34,SX*SY))

      RETURN
      END


program test_hankel1
  use types, only: dp
  use constants, only: i_
  use utils, only: assert
  use special, only: hankel1
  implicit none

  ! check a few value against the ones computed with SciPy:
  integer :: i
  real(dp), parameter :: eps = 1d-14
  real(dp), parameter :: ordersReal(7) = [0.000000000000000_dp, 1.000000000000000_dp, 2.000000000000000_dp,&
       3.300000000000000_dp, 7.000000000000000_dp,&
       -1.500000000000000_dp, -4.000000000000000_dp]
  real(dp), parameter :: xReal(7) = [1.100000000000000_dp, 3.000000000000000_dp, 10.000000000000000_dp,&
       2.100000000000000_dp, 5.500000000000000_dp, &
       1.100000000000000_dp, 2.000000000000000_dp]
  real(dp), parameter :: xImag(7) = [0.100000000000000_dp, -0.300000000000000_dp, 2.500000000000000_dp, &
       -1.800000000000000_dp, 2.000000000000000_dp, 0.500000000000000_dp, 1.500000000000000_dp]

  complex(dp), parameter :: correctResultsRealArg(7) = [(0.719622018527511_dp, 0.162163202926887_dp), &
       (0.339058958525936_dp, 0.324674424791800_dp), (0.254630313685121_dp, -0.005868082442209_dp),&
       (0.101980666751263_dp, -1.267804061151291_dp), (0.086601225791613_dp, -0.874921069456376_dp),&
       (-0.991692967169576_dp, -0.271278757000343_dp), (0.033995719807567_dp, -2.765943226330601_dp)]

  complex(dp), parameter :: correctResultsComplexArg(7) = [(0.651368317549290_dp, 0.118990468927329_dp),&
       (0.428137777037678_dp, 0.455161854334643_dp), (0.021205380414102_dp, -0.003435444019643_dp),&
       (0.085126712134597_dp, -0.593895774097617_dp), (-0.333857447002332_dp, -0.093364319238606_dp),&
       (-0.667664135826850_dp, 0.116458951902184_dp), (-0.750994544707426_dp, 0.404920577875372_dp)]

  ! test real argument with real order:
  do i = 1,7
     call assert(abs(hankel1(ordersReal(i), xReal(i)) - correctResultsRealArg(i)) < eps)
  end do

  ! test real argument with integer order:
  ! test those to machine precision
  call assert(abs(hankel1(0, xReal(1)) - hankel1FromDef(0, xReal(1))) <= epsilon(1.0_dp))
  call assert(abs(hankel1(1, xReal(2)) - hankel1FromDef(1, xReal(2))) <= epsilon(1.0_dp))
  call assert(abs(hankel1(2, xReal(3)) - hankel1FromDef(2, xReal(3))) <= epsilon(1.0_dp))
  call assert(abs(hankel1(3, xReal(4)) - hankel1FromDef(3, xReal(4))) <= epsilon(1.0_dp))
  call assert(abs(hankel1(4, xReal(5)) - hankel1FromDef(4, xReal(5))) <= epsilon(1.0_dp))

  ! test complex data with real order:
  do i = 1,7
     call assert(abs(hankel1(ordersReal(i), xReal(i)+i_*xImag(i)) - correctResultsComplexArg(i)) < eps)
  end do

contains

  function hankel1FromDef(order, x) result(z)
    integer, intent(in) :: order
    real(dp), intent(in) :: x
    complex(dp) :: z

    z = bessel_jn(order, x) + i_*bessel_yn(order, x)
  end function hankel1FromDef

end program test_hankel1


MODULE sub
USE param

CONTAINS
!=======================
SUBROUTINE init
REAL :: htot, hini(nz)

hmin = 0.01 ! minimum layer thickness
dx = 10.0 ! grid spacing
g = 9.81 ! acceleration due to gravity

! bathymetry
DO k = 1,nx
htotal(k) = 100.0
END DO

! triangle-shaped island
DO k = 31,51
 htotal(k) = 100.-95.*real(k-30)/21.
END DO

DO k = 52,71
 htotal(k) = 100.-95.*real(71-k+1)/20.
END DO

htotal(0) = -10.0
htotal(nx+1) = -10.0

! undisturbed layer thicknesses & interface displacements
DO i = 1,nz
hini(i) = 10.0
END DO
DO k = 0,nx+1
 htot = htotal(k)
 DO i = 1,nz
 hzero(i,k) = MAX(MIN(hini(i),htot),0.0)
 eta(i,k) = MAX(0.0,-htot)
 htot = htot - hini(1)
 END DO
END DO

! layer densities
rho(0) = 0.0 ! air density ignored
rho(1) = 1025.0
DO i = 2,nz
  rho(i) = 1026.0+REAL(i-2)/REAL(nz-2)*0.5
END DO

! boundary values for dp and eta
DO k = 0,nx+1
  dp(0,k) = 0.0 ! air pressure ignored
  eta(nz+1,k) = 0.0 ! sea floor is rigid
END DO

! store initial interface displacements
DO k = 0,nx+1
DO i = 1,nz+1
  eta0(i,k) = eta(i,k)
END DO
END DO

! layer thicknesses, wet\dry pointers and velocities
DO i = 1,nz
DO k = 0,nx+1
  h(i,k) = hzero(i,k)
  wet(i,k) = 1
  if(h(i,k) < hmin) wet(i,k) = 0
  u(i,k) = 0.
  un(i,k) = 0.
END DO
END DO

END SUBROUTINE init

!================
SUBROUTINE dyn

! local parameters
REAL :: pgradx
REAL :: hue, huw, hwp, hwn, hen, hep
REAL :: deta

! calculate dynamic pressure
  DO k = 0,nx+1
  DO i = 1,nz
    dp(i,k) = dp(i-1,k)+(rho(i)-rho(i-1))*g*eta(i,k)
  END DO
  END DO

DO k = 1,nx
DO i = 1,nz

! velocity predictor for wet grid cells
  pgradx = -(dp(i,k+1)-dp(i,k))/rho(i)/dx
  un(i,k) = 0.0
  IF(wet(i,k)==1) THEN
    IF((wet(i,k+1)==1).or.(pgradx>0.0)) un(i,k) = u(i,k)+dt*pgradx
  ELSE
    IF((wet(i,k+1)==1).and.(pgradx<0.0)) un(i,k) = u(i,k)+dt*pgradx
  END IF
END DO
END DO

! layer-thickness change predictor
DO k = 1,nx
DO i = 1,nz
  hep = 0.5*(un(i,k)+abs(un(i,k)))*h(i,k)
  hen = 0.5*(un(i,k)-abs(un(i,k)))*h(i,k+1)
  hue = hep+hen
  hwp = 0.5*(un(i,k-1)+abs(un(i,k-1)))*h(i,k-1)
  hwn = 0.5*(un(i,k-1)-abs(un(i,k-1)))*h(i,k)
  huw = hwp+hwn
  dhdt(i,k) = -(hue-huw)/dx
END DO
END DO

! update interface displacements
DO k = 1,nx
  deta = 0.0
  DO i = nz,1,-1
    deta = deta + dhdt(i,k)
    etan(i,k)= eta(i,k)+dt*deta
  END DO
END DO

! apply Shapiro filter
CALL shapiro

! update layer thicknesses, lateral velocities and wet/dry pointers
DO k = 1,nx
   DO i = 1,nz
    h(i,k) = hzero(i,k)+eta(i,k)-eta(i+1,k)-eta0(i,k)+eta0(i+1,k)
    u(i,k) = un(i,k)
    wet(i,k) = 1
    if(h(i,k)<hmin)wet(i,k) = 0
  END DO
END DO

END SUBROUTINE dyn

!======================
SUBROUTINE shapiro

!local parameters
REAL :: term1,term2

! 1-order Shapiro filter

DO i = 1,nz
DO k = 1,nx

IF(wet(i,k)==1)THEN
  term1 = (1.0-0.5*eps*(wet(i,k+1)+wet(i,k-1)))*etan(i,k)
  term2 = 0.5*eps*(wet(i,k+1)*etan(i,k+1)+wet(i,k-1)*etan(i,k-1))
  eta(i,k) = term1+term2
ELSE
  eta(i,k) = etan(i,k)
END IF

END DO
END DO

END SUBROUTINE shapiro

END MODULE sub


      MODULE m_sphbes
      use m_juDFT
c********************************************************************
c calculate spherical Bessel functions and derivatives of sqrt(e)*r
c                                   P. Marksteiner and E. Badralexe
c********************************************************************
      CONTAINS
      SUBROUTINE sphbes(
     >                  lmax,x,
     <                  fj)
!$acc routine
      IMPLICIT NONE
!     ..
!     .. Arguments ..
      INTEGER, INTENT  (IN) :: lmax
      REAL,    INTENT  (IN) :: x
      REAL,    INTENT (OUT) :: fj(0:lmax)
!
!     .. Parameters ..
      REAL,    PARAMETER :: small = 1.0e-03 , zero = 0.0
!     ..
!     .. Locals ..
      INTEGER i,l,min,n
      REAL fac,quot,xinv,xx
      REAL :: aux(0:int(lmax+10+x))
      !REAL, ALLOCATABLE :: aux(:)
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC abs,cos,sin

      IF (lmax==0) THEN
         IF (x.GE.small) THEN
            fj(0) = sin(x)/x
         ELSE
            fj(0) = 1 - x*x/6.* (1.-x*x/20.* (1.-x*x/42.))
         END IF
         RETURN
      ENDIF
!#ifdef _OPENACC
!      IF (x.LT.zero)  stop "sphbes2"
!#else
!      IF (x.LT.zero)  CALL juDFT_error("sphbes2",calledby="sphbes")
!#endif
      xx = x*x
      IF (x.GE.small) THEN
         xinv = 1./x
         fj(0) = sin(x)*xinv
         fj(1) = (fj(0)-cos(x))*xinv
      ELSE
         fj(0) = 1 - xx/6.* (1.-xx/20.* (1.-xx/42.))
         fj(1) = (x/3.)* (1.-xx/10.* (1.-xx/28.))
         fac = xx/15.
         DO l=2,lmax
           fj(l) = fac * ( 1. - xx / (4*l+6) )
           fac = x * fac / (2*l+3)
         ENDDO
         RETURN
      END IF
      IF (lmax.LT.x) THEN

         DO l = 2,lmax
            fj(l) = (2*l-1)*xinv*fj(l-1) - fj(l-2)
         ENDDO

      ELSE IF (lmax.GE.2) THEN
         n = INT( lmax + 10 + x )
       !  ALLOCATE( aux(0:n) )
!
! downward recursion from arbitrary starting values
!
         aux(n) = 0.
         aux(n-1) = 1.
         DO i = n - 1,1,-1
            aux(i-1) = (2*i+1)*xinv*aux(i) - aux(i+1)
         ENDDO
!
! normalize with j0 or j1, whichever is larger
!
         min = 0
         IF (abs(fj(0)).LT.abs(fj(1))) min = 1
         quot = fj(min)/aux(min)
         DO l = 2,lmax
            fj(l) = aux(l)*quot
         ENDDO
        ! DEALLOCATE( aux )
      END IF

      RETURN
      END SUBROUTINE sphbes
      END MODULE m_sphbes


      SUBROUTINE MOMENT(DATA,N,AVE,ADEV,SDEV,VAR,SKEW,CURT)
      DIMENSION DATA(N)
      IF(N.LE.1)PAUSE 'N must be at least 2'
      S=0.
      DO 11 J=1,N
        S=S+DATA(J)
11    CONTINUE
      AVE=S/N
      ADEV=0.
      VAR=0.
      SKEW=0.
      CURT=0.
      DO 12 J=1,N
        S=DATA(J)-AVE
        ADEV=ADEV+ABS(S)
        P=S*S
        VAR=VAR+P
        P=P*S
        SKEW=SKEW+P
        P=P*S
        CURT=CURT+P
12    CONTINUE
      ADEV=ADEV/N
      VAR=VAR/(N-1)
      SDEV=SQRT(VAR)
      IF(VAR.NE.0.)THEN
        SKEW=SKEW/(N*SDEV**3)
        CURT=CURT/(N*VAR**2)-3.
      ELSE
        PAUSE 'no skew or kurtosis when zero variance'
      ENDIF
      RETURN
      END


!Tests whether an integer is happy or sad
module test
    use const, only : rk, ik
    implicit none
    integer, parameter, private :: unhappy(8) = [4, 16, 37, 58, 89, 145, 42, 20]

    contains

    pure logical function O(x_in)
        implicit none
        integer(ik), intent(in) :: x_in
        integer(ik) :: x, i, sum

        x = x_in
        do
            sum = 0
            do i = 1, floor(log10(real(x, rk)) + 1)
                sum = sum + (x - (x / 10) * 10) ** 2
                x = x / 10
            end do
            x = sum

            if (x == 1) then
                O = .true.
                return
            else if (any(x == unhappy)) then
                O = .false.
                return
            end if
        end do
    end function O
end module test


Subroutine wida1(dmass, rhomp, wa1, iseed)
  Save
  pimass = 0.137265
  coupa = 14.8
  rhomax = dmass - pimass - 0.02
  If (rhomax<=0) Then
     rhomp = 0.
     wa1 = -10.
  End If
  icount = 0
711 rhomp = rhomas(rhomax, iseed)
  icount = icount + 1
  If (dmass<=(pimass+rhomp)) Then
     If (icount<=100) Then
        Goto 711
     Else
        rhomp = 0.
        wa1 = -10.
        Return
     End If
  End If
  qqp2 = (dmass**2-(rhomp+pimass)**2)*(dmass**2-(rhomp-pimass)**2)
  qqp = sqrt(qqp2)/(2.0*dmass)
  epi = sqrt(pimass**2+qqp**2)
  erho = sqrt(rhomp**2+qqp**2)
  epirho = 2.0*(epi*erho+qqp**2)**2 + rhomp**2*epi**2
  wa1 = coupa**2*qqp*epirho/(24.0*3.1416*dmass**2)
  Return
End Subroutine wida1


subroutine banslv ( w, nroww, nrow, nbandl, nbandu, b )

!*****************************************************************************80
!
!! BANSLV solves a banded linear system A * X = B factored by BANFAC.
!
!  Modified:
!
!    14 February 2007
!
!  Author:
!
!    Carl DeBoor
!
!  Reference:
!
!    Carl DeBoor,
!    A Practical Guide to Splines,
!    Springer, 2001,
!    ISBN: 0387953663.
!
!  Parameters:
!
!    Input, real ( kind = 8 ) W(NROWW,NROW).  W contains the banded matrix,
!    after it has been factored by BANFAC.
!
!    Input, integer NROWW, the row dimension of the work array W.
!    NROWW must be at least NBANDL+1 + NBANDU.
!
!    Input, integer NROW, the number of rows in A.
!
!    Input, integer NBANDL, the number of bands of A below the
!    main diagonal.
!
!    Input, integer NBANDU, the number of bands of A above the
!    main diagonal.
!
!    Input/output, real ( kind = 8 ) B(NROW).
!    On input, B contains the right hand side of the system to be solved.
!    On output, B contains the solution, X.
!
  implicit none

  integer nrow
  integer nroww

  real ( kind = 8 ) b(nrow)
  integer i
  integer j
  integer jmax
  integer middle
  integer nbandl
  integer nbandu
  real ( kind = 8 ) w(nroww,nrow)

  middle = nbandu + 1

  !print*, "ze",size(w,1),size(w,2)

  if ( nrow == 1 ) then
    b(1) = b(1) / w(middle,1)
    return
  end if
!
!  Forward pass:
!
!  For I = 1, 2, ..., NROW-1, subtract RHS(I)*(I-th column of L)
!  from the right hand side, below the I-th row.
!
  if ( 0 < nbandl ) then
    do i = 1, nrow-1
      jmax = min ( nbandl, nrow-i )
      do j = 1, jmax
        b(i+j) = b(i+j) - b(i) * w(middle+j,i)
      end do
    end do
  end if
!
!  Backward pass:
!
!  For I=NROW, NROW-1,...,1, divide RHS(I) by
!  the I-th diagonal entry of U, then subtract
!  RHS(I)*(I-th column of U) from right hand side, above the I-th row.
!
  do i = nrow, 2, -1

    b(i) = b(i) / w(middle,i)

    do j = 1, min ( nbandu, i-1 )
      b(i-j) = b(i-j) - b(i) * w(middle-j,i)
    end do

  end do

  b(1) = b(1) / w(middle,1)

  !print*, 'banslv',b
  return
end subroutine banslv


      PROGRAM xfpoly
C     driver for routine fpoly
      INTEGER NPOLY,NVAL
      REAL DX
      PARAMETER(NVAL=15,DX=0.1,NPOLY=5)
      INTEGER i,j
      REAL x,afunc(NPOLY)
      write(*,'(/1x,t29,a)') 'Powers of X'
      write(*,'(/1x,t9,a,t17,a,t27,a,t37,a,t47,a,t57,a)') 'X','X**0',
     *     'X**1','X**2','X**3','X**4'
      do 11 i=1,NVAL
        x=i*DX
        call fpoly(x,afunc,NPOLY)
        write(*,'(1x,6f10.4)') x,(afunc(j),j=1,NPOLY)
11    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xfpoly.for


submodule(forlab_linalg) forlab_linalg_qr

    implicit none

contains

    module procedure qr_sp
    real(sp), allocatable::v(:)
    integer::i, j, k, m, n, nn, templ
    real(sp)::alpha, t, u
    real(sp), parameter::eps = epsilon(1.0_sp), zero = 0.0_sp, one = 1.0_sp
    m = size(a, 1)
    n = size(a, 2)
    if (m < n) then
        call error_stop("Error:Matrix a dimension m < n ")
    end if
    if (present(l)) then
        templ = l
    else
        templ = 1
    end if
    select case (templ)
    case (1)
        r = a
        allocate (q(m, m))
        q = zero
        r = a
        forall (i=1:m)
            q(i, i) = one
        end forall
        nn = n
        if (m == n) nn = m - 1
        do k = 1, nn
            u = zero
            do i = k, m
                if (abs(r(i, k)) > u) u = abs(r(i, k))
            end do
            alpha = dot_product(r(k:m, k), r(k:m, k))/(u*u)
            if (r(k, k) > 0) u = -u
            alpha = u*sqrt(alpha)
            if (abs(alpha) < eps) then
                call error_stop("Error:matrix r linearly dependent")
            end if
            u = sqrt(2*alpha*(alpha - r(k, k)))
            if (abs(u) > eps) then
                r(k, k) = (r(k, k) - alpha)/u
                r(k + 1:m, k) = r(k + 1:m, k)/u
                do j = 1, m
                    t = dot_product(r(k:m, k), q(k:m, j))
                    q(k:m, j) = q(k:m, j) - 2*r(k:m, k)*t
                end do
                do j = k + 1, n
                    t = dot_product(r(k:m, k), r(k:m, j))
                    r(k:m, j) = r(k:m, j) - 2*r(k:m, k)*t
                end do
                r(k, k) = alpha
                r(k + 1:m, k) = zero
            end if
        end do
        do i = 1, m - 1
            do j = i + 1, m
                t = q(i, j)
                q(i, j) = q(j, i)
                q(j, i) = t
            end do
        end do
    case (2)
        allocate (r(n, n))
        r = zero
        q = a
        v = q(:, 1)
        alpha = norm2(v)
        q(:, 1) = v/alpha
        r(1, 1) = alpha
        do i = 2, n
            v = q(:, i)
            do j = 1, i - 1
                alpha = dot_product(q(:, i), q(:, j))
                v = v - alpha*q(:, j)
                r(j, i) = alpha
            end do
            alpha = norm2(v)
            if (abs(alpha) < eps) then
                call error_stop("Error:Matrix q linearly dependent")
            end if
            q(:, i) = v/alpha
            r(i, i) = alpha
        end do
    case default
        call Error_stop("Error: QR decomposition Type must be 1 or 2")
    end select
    end procedure qr_sp
    module procedure qr_dp
    real(dp), allocatable::v(:)
    integer::i, j, k, m, n, nn, templ
    real(dp)::alpha, t, u
    real(dp), parameter::eps = epsilon(1.0_dp), zero = 0.0_dp, one = 1.0_dp
    m = size(a, 1)
    n = size(a, 2)
    if (m < n) then
        call error_stop("Error:Matrix a dimension m < n ")
    end if
    if (present(l)) then
        templ = l
    else
        templ = 1
    end if
    select case (templ)
    case (1)
        r = a
        allocate (q(m, m))
        q = zero
        r = a
        forall (i=1:m)
            q(i, i) = one
        end forall
        nn = n
        if (m == n) nn = m - 1
        do k = 1, nn
            u = zero
            do i = k, m
                if (abs(r(i, k)) > u) u = abs(r(i, k))
            end do
            alpha = dot_product(r(k:m, k), r(k:m, k))/(u*u)
            if (r(k, k) > 0) u = -u
            alpha = u*sqrt(alpha)
            if (abs(alpha) < eps) then
                call error_stop("Error:matrix r linearly dependent")
            end if
            u = sqrt(2*alpha*(alpha - r(k, k)))
            if (abs(u) > eps) then
                r(k, k) = (r(k, k) - alpha)/u
                r(k + 1:m, k) = r(k + 1:m, k)/u
                do j = 1, m
                    t = dot_product(r(k:m, k), q(k:m, j))
                    q(k:m, j) = q(k:m, j) - 2*r(k:m, k)*t
                end do
                do j = k + 1, n
                    t = dot_product(r(k:m, k), r(k:m, j))
                    r(k:m, j) = r(k:m, j) - 2*r(k:m, k)*t
                end do
                r(k, k) = alpha
                r(k + 1:m, k) = zero
            end if
        end do
        do i = 1, m - 1
            do j = i + 1, m
                t = q(i, j)
                q(i, j) = q(j, i)
                q(j, i) = t
            end do
        end do
    case (2)
        allocate (r(n, n))
        r = zero
        q = a
        v = q(:, 1)
        alpha = norm2(v)
        q(:, 1) = v/alpha
        r(1, 1) = alpha
        do i = 2, n
            v = q(:, i)
            do j = 1, i - 1
                alpha = dot_product(q(:, i), q(:, j))
                v = v - alpha*q(:, j)
                r(j, i) = alpha
            end do
            alpha = norm2(v)
            if (abs(alpha) < eps) then
                call error_stop("Error:Matrix q linearly dependent")
            end if
            q(:, i) = v/alpha
            r(i, i) = alpha
        end do
    case default
        call Error_stop("Error: QR decomposition Type must be 1 or 2")
    end select
    end procedure qr_dp

end submodule forlab_linalg_qr


subroutine elmhes(heslo,hessi,ndime,nnode,ntens,xjaci,deriv,elcod)
!-----------------------------------------------------------------------
!****f* Domain/elmhes
! NAME
!    elmhes
! DESCRIPTION
!    This routine computes the Hessian matrix in the Cartesian system
!    of coordinates according to the rule
!
!    d^2 N / d x_i d x_j
!       = (d^2 N / d s_k d s_l) (d s_k/ d x_i)(d s_l/ d x_j)
!       + (d N / d s_k) (d^2 s_k / d x_i d x_j)
! USES
!    vetoma
!    btdbma
!    matove
! SOURCE
!***
!-----------------------------------------------------------------------
  use typre
  implicit none

  integer(ip), intent(in)  :: ndime,nnode,ntens
  real(rp),    intent(in)  :: xjaci(ndime,ndime)
  real(rp),    intent(in)  :: deriv(ndime,nnode),elcod(ndime,nnode)
  real(rp),    intent(in)  :: heslo(ntens,nnode)
  real(rp),    intent(out) :: hessi(ntens,nnode)

  real(rp) :: wmat1(ndime,ndime,nnode)      !really only
  real(rp) :: wmat2(ndime,ndime,nnode)      !work not even
  real(rp) :: d2sdx(ndime,ndime,ndime)      !intent out
  integer(ip)              :: inode,idime,jdime,kdime,ldime
!
! Transforms the array HESLO to a symmetric matrix WMAT1
!
  do inode=1,nnode
     call vetoma(heslo(1,inode),wmat1(1,1,inode),ndime,ntens)
  end do
!
! Computes (d^2 N / d s_k d s_l) (d s_k/ d x_i)(d s_l/ d x_j) for
! each node
!
  do inode=1,nnode
     call btdbma(wmat2(1,1,inode),wmat1(1,1,inode),xjaci,ndime,ndime)
  end do
!
! Obtains (d^2 s_k / d x_i d x_j) as the solution of the system
! (d x_l / d s_k) (d^2 s_k / d x_i d x_j)
!     = - (d^2 x_l / d s_k d s_l) (d s_k/ d x_i)(d s_l/ d x_j),
! for l,i,j = 1,...,NDIME
!
  do kdime=1,ndime
     do idime=1,ndime
        do jdime=1,ndime
           d2sdx(kdime,idime,jdime)=0.0_rp
           do ldime=1,ndime
              do inode=1,nnode
                 d2sdx(kdime,idime,jdime)=d2sdx(kdime,idime,jdime)&
                      -xjaci(kdime,ldime)*wmat2(idime,jdime,inode)&
                      *elcod(ldime,inode)
              end do
           end do
        end do
     end do
  end do
!
! Computes the second Cartesian derivatives of the shape functions
!
  do inode=1,nnode
     do idime=1,ndime
        do jdime=1,ndime
           do kdime=1,ndime
              wmat2(idime,jdime,inode)=wmat2(idime,jdime,inode)&
                   +deriv(kdime,inode)*d2sdx(kdime,idime,jdime)
           end do
        end do
     end do
  end do
!
! Writes the Hessian matrix as an array
!
  do inode=1,nnode
     call matove(wmat2(1,1,inode),hessi(1,inode),ndime,ntens)
  end do

end subroutine elmhes


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1997  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  function sigmoid  --  general sigmoidal functional form  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "sigmoid" implements a normalized sigmoidal function on the
c     interval [0,1]; the curves connect (0,0) to (1,1) and have
c     a cooperativity controlled by beta, they approach a straight
c     line as beta -> 0 and get more nonlinear as beta increases
c
c
      function sigmoid (beta,x)
      implicit none
      real*8 beta,x
      real*8 sigmoid
      real*8 expmax
      real*8 expmin
      real*8 expterm
c
c
c     compute the value of the normalized sigmoidal function
c
      if (beta .eq. 0.0d0) then
         sigmoid = x
      else
         expmax = 1.0d0 / (exp(-beta) + 1.0d0)
         expmin = 1.0d0 / (exp(beta) + 1.0d0)
         expterm = 1.0d0 / (exp(beta*(2.0d0*x-1.0d0)) + 1.0d0)
         sigmoid = (expmax - expterm) / (expmax - expmin)
      end if
      return
      end


*DECK BETAI
      REAL FUNCTION BETAI (X, PIN, QIN)
C***BEGIN PROLOGUE  BETAI
C***PURPOSE  Calculate the incomplete Beta function.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7F
C***TYPE      SINGLE PRECISION (BETAI-S, DBETAI-D)
C***KEYWORDS  FNLIB, INCOMPLETE BETA FUNCTION, SPECIAL FUNCTIONS
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C   BETAI calculates the REAL incomplete beta function.
C
C   The incomplete beta function ratio is the probability that a
C   random variable from a beta distribution having parameters PIN and
C   QIN will be less than or equal to X.
C
C     -- Input Arguments -- All arguments are REAL.
C   X      upper limit of integration.  X must be in (0,1) inclusive.
C   PIN    first beta distribution parameter.  PIN must be .GT. 0.0.
C   QIN    second beta distribution parameter.  QIN must be .GT. 0.0.
C
C***REFERENCES  Nancy E. Bosten and E. L. Battiste, Remark on Algorithm
C                 179, Communications of the ACM 17, 3 (March 1974),
C                 pp. 156.
C***ROUTINES CALLED  ALBETA, R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920528  DESCRIPTION and REFERENCES sections revised.  (WRB)
C***END PROLOGUE  BETAI
      LOGICAL FIRST
      SAVE EPS, ALNEPS, SML, ALNSML, FIRST
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  BETAI
      IF (FIRST) THEN
         EPS = R1MACH(3)
         ALNEPS = LOG(EPS)
         SML = R1MACH(1)
         ALNSML = LOG(SML)
      ENDIF
      FIRST = .FALSE.
C
      IF (X .LT. 0. .OR. X .GT. 1.0) CALL XERMSG ('SLATEC', 'BETAI',
     +   'X IS NOT IN THE RANGE (0,1)', 1, 2)
      IF (PIN .LE. 0. .OR. QIN .LE. 0.) CALL XERMSG ('SLATEC', 'BETAI',
     +   'P AND/OR Q IS LE ZERO', 2, 2)
C
      Y = X
      P = PIN
      Q = QIN
      IF (Q.LE.P .AND. X.LT.0.8) GO TO 20
      IF (X.LT.0.2) GO TO 20
      Y = 1.0 - Y
      P = QIN
      Q = PIN
C
 20   IF ((P+Q)*Y/(P+1.).LT.EPS) GO TO 80
C
C EVALUATE THE INFINITE SUM FIRST.
C TERM WILL EQUAL Y**P/BETA(PS,P) * (1.-PS)I * Y**I / FAC(I)
C
      PS = Q - AINT(Q)
      IF (PS.EQ.0.) PS = 1.0
      XB = P*LOG(Y) -  ALBETA(PS, P) - LOG(P)
      BETAI = 0.0
      IF (XB.LT.ALNSML) GO TO 40
C
      BETAI = EXP (XB)
      TERM = BETAI*P
      IF (PS.EQ.1.0) GO TO 40
C
      N = MAX (ALNEPS/LOG(Y), 4.0E0)
      DO 30 I=1,N
        TERM = TERM*(I-PS)*Y/I
        BETAI = BETAI + TERM/(P+I)
 30   CONTINUE
C
C NOW EVALUATE THE FINITE SUM, MAYBE.
C
 40   IF (Q.LE.1.0) GO TO 70
C
      XB = P*LOG(Y) + Q*LOG(1.0-Y) - ALBETA(P,Q) - LOG(Q)
      IB = MAX (XB/ALNSML, 0.0E0)
      TERM = EXP (XB - IB*ALNSML)
      C = 1.0/(1.0-Y)
      P1 = Q*C/(P+Q-1.)
C
      FINSUM = 0.0
      N = Q
      IF (Q.EQ.REAL(N)) N = N - 1
      DO 50 I=1,N
        IF (P1.LE.1.0 .AND. TERM/EPS.LE.FINSUM) GO TO 60
        TERM = (Q-I+1)*C*TERM/(P+Q-I)
C
        IF (TERM.GT.1.0) IB = IB - 1
        IF (TERM.GT.1.0) TERM = TERM*SML
C
        IF (IB.EQ.0) FINSUM = FINSUM + TERM
 50   CONTINUE
C
 60   BETAI = BETAI + FINSUM
 70   IF (Y.NE.X .OR. P.NE.PIN) BETAI = 1.0 - BETAI
      BETAI = MAX (MIN (BETAI, 1.0), 0.0)
      RETURN
C
 80   BETAI = 0.0
      XB = P*LOG(MAX(Y,SML)) - LOG(P) - ALBETA(P,Q)
      IF (XB.GT.ALNSML .AND. Y.NE.0.) BETAI = EXP (XB)
      IF (Y.NE.X .OR. P.NE.PIN) BETAI = 1.0 - BETAI
      RETURN
C
      END


      subroutine calsig(lmax,r,
     >                  xp,nbnd,
     >                  tnode,node,wgq,xgq,npts,
     >                  wylm,plm,sumfi)
c     ================================================================
c
c*********************************************************************
c*                                                                   *
c*    This is the new program to expand sigma(r) on complex spherical*
c*    harmonics. It only requires the position of boundary planes.   *
c*                                                                   *
c*    the integration :                                              *
c*                       /                                           *
c*                       |  _          _      *   _                  *
c*                       | do * sigma( r ) * y  ( r ) = wylm         *
c*                       |                    l,m                    *
c*                       /                                           *
c*                                                                   *
c*    for certain r and m => 0, is carried through this subroutine.  *
c*                                                                   *
c*                             m        *                            *
c*    For m < 0, w(l,-m) = (-1) * w(l,m)                             *
c*                                                                   *
c*                               *                                   *
c*                       = w(l,m)         if m = even                *
c*                                                                   *
c*    The array is stored in the following way:                      *
c*                                                                   *
c*        jl       l       m              jl      l      m           *
c*                                                                   *
c*      w( 1 )     0       0            w( 7 )    3      0           *
c*      w( 2 )     1       0            w( 8 )    3      1           *
c*      w( 3 )     1       1            w( 9 )    3      2           *
c*      w( 4 )     2       0            w(10 )    3      3           *
c*      w( 5 )     2       1               .      .      .           *
c*      w( 6 )     2       2               .      .      .           *
c*                                         .      .      .           *
c*                                                                   *
c*    input:                                                         *
c*                                                                   *
c*          lmax     = the maximum value of l.                       *
c*          xgq      = the Gaussian quadrature points.               *
c*          wgq      = the Gaussian quadrature weight associating    *
c*                     each value of xgq.                            *
c*          npts     = the number of Gaussian qurdrature points.     *
c*          r        = the ratial value.                             *
c*          xp       = the vector normal to a boundary plane and     *
c*                     ending on the plane (from origin).            *
c*          nbnd     = the number of boundary planes.                *
c*          tnode    = the nodes along theta integration which is the*
c*                     non-regular points of function: f(theta).     *
c*                     The integration over theta is broken into     *
c*                     several pieces, each of which has two nodes as*
c*                     the terminal points.                          *
c*          node     = the number of tnode.                          *
c*                                                                   *
c*                                                                   *
c*    output:                                                        *
c*                                                                   *
c*          wylm     = step function expansion value for current     *
c*                     value of r.                                   *
c*                                                                   *
c*********************************************************************
c
      implicit   none
c
      integer    lmax
      integer    nbnd
      integer    node
      integer    npts
      integer    i
      integer    l,m,jl
      integer    n
c
      real*8     wgq(npts)
      real*8     xgq(npts)
      real*8     tnode(node)
      real*8     wt
      real*8     plm((lmax+1)*(lmax+2)/2)
      real*8     xp(3,nbnd)
      real*8     cosrth,offset
      real*8     half
      real*8     one
      real*8     two
      real*8     wtol
      real*8     d,halfd
      real*8     h0,sh0
      real*8     r,u
      real*8 t(2)
c
      complex*16 sumfi(0:lmax,3)
      complex*16 wylm((lmax+1)*(lmax+2)/2)
      complex*16 af1
      complex*16 czero
c
      parameter  (half=0.5d0)
      parameter  (one=1.0d0)
      parameter  (two=2.0d0)
      parameter  (wtol=1.0d-14)
      parameter  (czero=(0.d0,0.d0))
c
c     ================================================================
c     start to integrate over xn=cos(theta), using gaussian method.
c
c             2pi              ->   -i*m*phi
c     sumfi = int d(phi) sigma(r )*e        ,   for certain cos(theta)
c              0
c
c     ================================================================
      do i=1,node-1
         d=tnode(i+1)-tnode(i)
         h0=d*1.d-6
	 if(h0.lt.1.d-8) h0=min(1.d-8,d*1.d-3)
         sh0=sqrt(h0)

         call intphi(lmax,tnode(i),r,xp,nbnd,sumfi(0,3))
         call intphi(lmax,tnode(i)+h0,r,xp,nbnd,sumfi(0,1))
         do m=0,lmax
	   sumfi(m,1)=(sumfi(m,1)-sumfi(m,3))/sh0
	 enddo
c
         call intphi(lmax,tnode(i+1),r,xp,nbnd,sumfi(0,3))
         call intphi(lmax,tnode(i+1)-h0,r,xp,nbnd,sumfi(0,2))
         do m=0,lmax
	   sumfi(m,2)=(sumfi(m,2)-sumfi(m,3))/sh0
	 enddo
c
	 offset=half*(tnode(i)+tnode(i+1))
	 halfd=half*d
         do n=1,npts
            cosrth=offset+halfd*xgq(n)
c
c           ==========================================================
c           generate the Legendre functions up to
c           l = lmax for each cos(theta) value.
c           ==========================================================
c           ----------------------------------------------------------
! meis: changed to normalized associated Legendre functions
            call plm_normalized(lmax,cosrth,plm)
c           ----------------------------------------------------------
            call intphi(lmax,cosrth,r,xp,nbnd,sumfi(0,3))
c           ----------------------------------------------------------
c
	    t(1)=sqrt(halfd+halfd*xgq(n))
	    t(2)=sqrt(halfd-halfd*xgq(n))
            wt=wgq(n)*halfd
	    do m=0,lmax
              af1= wt*(sumfi(m,3) -
     >                    sumfi(m,1)*t(1)-sumfi(m,2)*t(2))
	      jl=m*(m+1)/2+1
	    do l=m,lmax
	      jl=jl+l
               wylm(jl) = wylm(jl)+af1*plm(jl)
            enddo
            enddo
c
	    if(xgq(n).ge.0.d0) then
            u=sqrt(d)*xgq(n)
	    wt=two*sqrt(d)*wgq(n)*u*u
c           ----------------------------------------------------------
! meis: changed to normalized associated Legendre functions
            call plm_normalized(lmax,u*u+tnode(i),plm)
c           ----------------------------------------------------------
	    do m=0,lmax
	      af1=wt*sumfi(m,1)
	      jl=m*(m+1)/2+1
	    do l=m,lmax
	      jl=jl+l
               wylm(jl)=wylm(jl)+af1*plm(jl)
            enddo
            enddo
c           ----------------------------------------------------------
! meis: changed to normalized associated Legendre functions
            call plm_normalized(lmax,tnode(i+1)-u*u,plm)
c           ----------------------------------------------------------
	    do m=0,lmax
	      af1=wt*sumfi(m,2)
	      jl=m*(m+1)/2+1
	    do l=m,lmax
	      jl=jl+l
               wylm(jl)=wylm(jl)+af1*plm(jl)
            enddo
            enddo
	    endif
         enddo
      enddo
c
      do jl=1,(lmax+1)*(lmax+2)/2
         if(abs(wylm(jl)) .lt. wtol) then
            wylm(jl)=czero
         endif
      enddo
c
      return
      end


*DECK CPOFA
      SUBROUTINE CPOFA (A, LDA, N, INFO)
C***BEGIN PROLOGUE  CPOFA
C***PURPOSE  Factor a complex Hermitian positive definite matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2D1B
C***TYPE      COMPLEX (SPOFA-S, DPOFA-D, CPOFA-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION,
C             POSITIVE DEFINITE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     CPOFA factors a complex Hermitian positive definite matrix.
C
C     CPOFA is usually called by CPOCO, but it can be called
C     directly with a saving in time if  RCOND  is not needed.
C     (Time for CPOCO) = (1 + 18/N)*(Time for CPOFA) .
C
C     On Entry
C
C        A       COMPLEX(LDA, N)
C                the Hermitian matrix to be factored.  Only the
C                diagonal and upper triangle are used.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C     On Return
C
C        A       an upper triangular matrix  R  so that  A =
C                CTRANS(R)*R where  CTRANS(R)  is the conjugate
C                transpose.  The strict lower triangle is unaltered.
C                If  INFO .NE. 0 , the factorization is not complete.
C
C        INFO    INTEGER
C                = 0  for normal return.
C                = K  signals an error condition.  The leading minor
C                     of order  K  is not positive definite.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  CDOTC
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CPOFA
      INTEGER LDA,N,INFO
      COMPLEX A(LDA,*)
C
      COMPLEX CDOTC,T
      REAL S
      INTEGER J,JM1,K
C***FIRST EXECUTABLE STATEMENT  CPOFA
         DO 30 J = 1, N
            INFO = J
            S = 0.0E0
            JM1 = J - 1
            IF (JM1 .LT. 1) GO TO 20
            DO 10 K = 1, JM1
               T = A(K,J) - CDOTC(K-1,A(1,K),1,A(1,J),1)
               T = T/A(K,K)
               A(K,J) = T
               S = S + REAL(T*CONJG(T))
   10       CONTINUE
   20       CONTINUE
            S = REAL(A(J,J)) - S
            IF (S .LE. 0.0E0 .OR. AIMAG(A(J,J)) .NE. 0.0E0) GO TO 40
            A(J,J) = CMPLX(SQRT(S),0.0E0)
   30    CONTINUE
         INFO = 0
   40 CONTINUE
      RETURN
      END


    Program zhseqr_example

!     ZHSEQR Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: zgemm
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen_comp
      Use lapack_interfaces, Only: zhseqr, zlange
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Complex (Kind=dp) :: alpha, beta
      Real (Kind=dp) :: norm
      Integer :: i, ifail, info, ldc, ldd, ldh, ldz, lwork, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: c(:, :), d(:, :), h(:, :), w(:), &
        work(:), z(:, :)
      Real (Kind=dp) :: rwork(1)
      Character (1) :: clabs(1), rlabs(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: cmplx, epsilon
!     .. Executable Statements ..
      Write (nout, *) 'ZHSEQR Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldc = n
      ldd = n
      ldh = n
      ldz = n
      lwork = n
      Allocate (c(ldc,n), d(ldd,n), h(ldh,n), w(n), work(lwork), z(ldz,n))

!     Read H from data file

      Read (nin, *)(h(i,1:n), i=1, n)

!     Store H in D
      d(1:ldd, 1:n) = h(1:ldh, 1:n)

!     Print matrix H
!     ifail: behaviour on error exit
!            =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, n, h, &
        ldh, 'Bracketed', 'F7.4', 'Matrix H', 'Integer', rlabs, 'Integer', &
        clabs, 80, 0, ifail)

!     Calculate the eigenvalues and Schur factorization of H

      Call zhseqr('Schur form', 'Initialize Z', n, 1, n, h, ldh, w, z, ldz, &
        work, lwork, info)

      Write (nout, *)
      If (info>0) Then
        Write (nout, *) 'Failure to converge.'
      Else

!       Compute A - Z*T*Z^H from Schur factorization of A, and store in matrix
!       D
        alpha = cmplx(1, kind=dp)
        beta = cmplx(0, kind=dp)
        Call zgemm('N', 'N', n, n, n, alpha, z, ldz, h, ldh, beta, c, ldc)
        alpha = cmplx(-1, kind=dp)
        beta = cmplx(1, kind=dp)
        Call zgemm('N', 'C', n, n, n, alpha, c, ldc, z, ldz, beta, d, ldd)

!       Find norm of matrix D and print warning if it is too large
        norm = zlange('O', ldd, n, d, ldd, rwork)

        If (norm>epsilon(1.0E0_dp)**0.5_dp) Then
          Write (nout, *) 'Norm of A-(Z*T*Z^H) is much greater than 0.'
          Write (nout, *) 'Schur factorization has failed.'
        Else
!         Print eigenvalues
          Write (nout, *) 'Eigenvalues'
          Write (nout, 100)(w(i), i=1, n)
        End If

      End If

100   Format ((3X,4(' (',F7.4,',',F7.4,')',:)))
    End Program


!===================================================================================
!=================== SUBROUTINE RUNGE - KUTTA 4 ====================================
!===================================================================================

subroutine rk42css(Nx,Ny,Nh,alpha,nu,time,dt,omegak,omegak_new,dt_omegak_old,dt_omegak_new)
implicit none
integer ( kind = 4 ) Nx,Ny,Nh, i, j
real ( kind = 8 ) time,dt,alpha,nu,lambda
complex ( kind = 8 ) komega1(Nh,Ny),komega2(Nh,Ny),komega3(Nh,Ny),komega4(Nh,Ny)
complex ( kind = 8 ) omegak(Nh,Ny),omegak_new(Nh,Ny),dum_omegak(Nh,Ny),dt_omegak(Nh,Ny)
complex ( kind = 8 ) dt_omegak_old(Nh,Ny)
complex ( kind = 8 ) dt_omegak_new(Nh,Ny)

do i = 1,Nh
  do j = 1,Ny
    komega1(i,j) = dt_omegak(i,j)
    dum_omegak(i,j) = omegak(i,j) + komega1(i,j)*dt/2.0
  end do
end do

  call derive2css(Nx,Ny,Nh,alpha,nu,time+dt/2.0,dum_omegak,omegak_new,dt_omegak_old,dt_omegak_new)

do i = 1,Nh
  do j = 1,Ny
    komega2(i,j) = dt_omegak(i,j)
    dum_omegak(i,j) = omegak(i,j) + komega2(i,j)*dt/2.0
  end do
end do

  call derive2css(Nx,Ny,Nh,alpha,nu,time+dt/2.0,dum_omegak,omegak_new,dt_omegak_old,dt_omegak_new)

do i = 1,Nh
  do j = 1,Ny
    komega3(i,j) = dt_omegak(i,j)
    dum_omegak(i,j) = omegak(i,j) + komega3(i,j)*dt/2.0
  end do
end do

  call derive2css(Nx,Ny,Nh,alpha,nu,time+dt,dum_omegak,omegak_new,dt_omegak_old,dt_omegak_new)

do i = 1,Nh
  do j = 1,Ny
    komega4(i,j) = dt_omegak(i,j)
    omegak_new(i,j) = omegak(i,j) + dt/6.0d0*(komega1(i,j) + 2.0d0*komega2(i,j) + 2.0d0*komega3(i,j) + komega4(i,j))
!    omegak_new(i,j) = omegak(i,j) + komega1(i,j)*dt     ! EULER SOLVER
  end do
end do

return

end subroutine rk42css


      subroutine halopotentialestimate

      include 'commonblocks'
      common /haloestimate/ hdens(0:nmax),hpot(0:nmax),hfr(0:nmax)

      eps = 0.0001

      do ir=0,nr
         r=ir*dr
         if(r.eq.0.) r = eps
         hdens(ir)=halodensity(r)
 77   enddo

c     now get the potential harmonics of this new density. (BT 2-208)
c     Simpson's rule integration.

      s1(0)=0
      r = 2*dr
      s1(2)=(r*dr/3.)*(4*hdens(1)*(1.0-dr/r)**2+hdens(2))
      rold = r
      do ir=4,nr,2
         r=ir*dr
         s1a = (r*dr/3.)*(hdens(ir-2)*(1.0-2*dr/r)**2+
     +        4*hdens(ir-1)*(1.0-dr/r)**2+hdens(ir))
         s1(ir) = s1a + s1(ir-2)*rold/r
         rold = r
      enddo
      s2(nr)=0
      rold = nr*dr
      do ir=nr-2,2,-2
         r=ir*dr
         s2a = (r*dr/3.)*(hdens(ir+2)*(1.0+2*dr/r)+
     &        4*hdens(ir+1)*(1.0+dr/r)+hdens(ir))
         s2(ir) = s2a + s2(ir+2)
         rold = r
      enddo

      do ir = 2,nr,2
         r = ir*dr
         hpot(ir)=(4.*pi)*(s1(ir)+s2(ir))
         hfr(ir)=-(4.*pi)*s1(ir)/r
      enddo

      hpot(0)=3*(hpot(2)-hpot(4))+hpot(6)
      hfr(0)=0.0

c     then linearly interpolate other bins.

      do ir=1,nr-1,2
         hpot(ir)=(hpot(ir-1)+hpot(ir+1))/2.
         hfr(ir)=(hfr(ir-1)+hfr(ir+1))/2.
      enddo

      return
      end

      function haloforce(r)

      include 'commonblocks'
      common /haloestimate/ hdens(0:nmax),hpot(0:nmax),hfr(0:nmax)

      ihi=int(r/dr)+1
      if (ihi.lt.1) ihi=1
      if (ihi.gt.nr) ihi=nr
      r1=dr*(ihi-1)
      r2=dr*ihi
      t=(r-r1)/(r2-r1)
      tm1 = 1.0 - t
      if (r.eq.0.) then
         lmaxx=0
         costheta=0
      else
         costheta=z/r
         lmaxx=lmax
      endif
      haloforce = (t*hfr(ihi)+ tm1*hfr(ihi-1))

      return
      end


c=======================================================================
c
c     subroutine SCHURO
c
c     Matrix Schur Decomposition and sorts eigenvalues (decrease order)
c     cf. SCHUR subroutine
c
c-----------------------------------------------------------------------
      SUBROUTINE schuro ( n, X, iwork, dwork,
     &                    eigval, soreig, vpmat, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : matrix size                                integer
c            X      : matrix (n*n)                                double
c
c     WORKSPACE
c            iwork  : vector (n)                                 integer
c            dwork  : vector ( n*(2*n+6) )                        double
c
c     OUTPUT
c            eigval : eigenvalues (n)                             double
c            soreig : sorted eigenvalues (n)                      double
c            vpmat  : eigenvectors (n*n)                          double
c            info   : diagnostic argument                        integer
c
c     CALL
c            SCHUR  : matrix Schur decomposition
c            AVODI  : sorts a vector (decrease order) with index in old vector
c            ACMI   : sorts the columns of a vectorized matrix as index
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info
      DOUBLE PRECISION eigval(*), soreig(*), X(*), vpmat(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER piw, pvs, pdw
c
c     external subroutines
      EXTERNAL schur, AVODI, ACMI
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      piw = 1
c     piw   : pointer for SCHUR, AVODI and ACMI  who need (n)
c     pinext = piw + ( n )
c     pinext : pointer for the next iwork array
c
c     Total size of iwork array ( n )
c
c     pointers for double precision work space  : work(nasmax,*)
c     ----------------------------------------------------------
      pvs = 1
c     pvs    : pointer eigenvectors matrix so (n*n) more
      pdw = pvs + ( n*n )
c     pdw    : pointer SCHUR who needs ( n*(n+6) ), so ( n*(n+6) ) more
c     pdnext  : pointer of the next dwork array
c
c     Total size of work array = ( n*(2*n + 6) )
c
c-----------------------------------------------------------------------
c
c     Schur factorization
      CALL schur ( n, X, iwork(piw), dwork(pdw),
     &             eigval, dwork(pvs), info )
      IF (info .LT. 0) RETURN
c
c     sorts the eigenvalues vector (decrease index order)
c     iwork is index of vector elements in the old vector
      CALL AVODI ( n, eigval, soreig, iwork(piw) )
c
c     sorts the columns of a vs (eigenvectors) as index
c     iwork is index of vector elements in the old vector
      CALL ACMI ( n, n, dwork(pvs), iwork(piw), vpmat )
c
      RETURN
      END


!> @ingroup insertion_sort_asc
!>
!> @brief
!> Run an insertion sort on a vector of double precision values.
!>
!> @details
!> Run an ascending on a vector of double precision values to sort them in the specified order.
!>
!> @param vec
!> The vector double precision values to be sorted.
!>
!> @author Arin R. Bratt
!> @date 11/07/2014
pure subroutine insertion_sort_asc_dble(vec)
  ! Arguments
  double precision, intent(inout) :: vec(:)

  ! Variables
  double precision :: double_precision_value
  double precision :: swap_value
  integer :: i
  integer :: j

  ! Sort to the first element
  if (vec(size(vec,1)) > vec(1)) then
     double_precision_value = vec(1)
  else
     double_precision_value = vec(size(vec,1))
     vec(size(vec,1)) = vec(1)
  end if

  do i = size(vec,1) - 1,2,-1
     if (double_precision_value > vec(i)) then
        ! Swap double precision values double_precision_value and vec(i).
        swap_value = double_precision_value
        double_precision_value = vec(i)
        vec(i) = swap_value
     end if
  end do

  ! Run regualr insertion sort
  do j = 3,size(vec,1)
     swap_value = vec(j)
     i = j - 1
     if (vec(i) > swap_value) then
        vec(j) = vec(i)
        i = i - 1
        do
           if (.not. vec(i) > swap_value) exit
           vec(i + 1) = vec(i)
           i = i - 1
        end do
        vec(i + 1) = swap_value
     end if
  end do
end subroutine insertion_sort_asc_dble


      SUBROUTINE slSVDS (M, N, MP, NP, B, U, W, V, WORK, X)
*+
*     - - - - - - -
*      S V D S
*     - - - - - - -
*
*  From a given vector and the SVD of a matrix (as obtained from
*  the SVD routine), obtain the solution vector (double precision)
*
*  This routine solves the equation:
*
*     A . x = b
*
*  where:
*
*     A   is a given M (rows) x N (columns) matrix, where M.GE.N
*     x   is the N-vector we wish to find
*     b   is a given M-vector
*
*  by means of the Singular Value Decomposition method (SVD).  In
*  this method, the matrix A is first factorised (for example by
*  the routine slSVD) into the following components:
*
*     A = U x W x VT
*
*  where:
*
*     A   is the M (rows) x N (columns) matrix
*     U   is an M x N column-orthogonal matrix
*     W   is an N x N diagonal matrix with W(I,I).GE.0
*     VT  is the transpose of an NxN orthogonal matrix
*
*     Note that M and N, above, are the LOGICAL dimensions of the
*     matrices and vectors concerned, which can be located in
*     arrays of larger PHYSICAL dimensions MP and NP.
*
*  The solution is found from the expression:
*
*     x = V . [diag(1/Wj)] . (transpose(U) . b)
*
*  Notes:
*
*  1)  If matrix A is square, and if the diagonal matrix W is not
*      adjusted, the method is equivalent to conventional solution
*      of simultaneous equations.
*
*  2)  If M>N, the result is a least-squares fit.
*
*  3)  If the solution is poorly determined, this shows up in the
*      SVD factorisation as very small or zero Wj values.  Where
*      a Wj value is small but non-zero it can be set to zero to
*      avoid ill effects.  The present routine detects such zero
*      Wj values and produces a sensible solution, with highly
*      correlated terms kept under control rather than being allowed
*      to elope to infinity, and with meaningful values for the
*      other terms.
*
*  Given:
*     M,N    i         numbers of rows and columns in matrix A
*     MP,NP  i         physical dimensions of array containing matrix A
*     B      d(M)      known vector b
*     U      d(MP,NP)  array containing MxN matrix U
*     W      d(N)      NxN diagonal matrix W (diagonal elements only)
*     V      d(NP,NP)  array containing NxN orthogonal matrix V
*
*  Returned:
*     WORK   d(N)      workspace
*     X      d(N)      unknown vector x
*
*  Reference:
*     Numerical Recipes, section 2.9.
*
*  P.T.Wallace   Starlink   29 October 1993
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      INTEGER M,N,MP,NP
      DOUBLE PRECISION B(M),U(MP,NP),W(N),V(NP,NP),WORK(N),X(N)

      INTEGER J,I,JJ
      DOUBLE PRECISION S

*  Calculate [diag(1/Wj)] . transpose(U) . b (or zero for zero Wj)
      DO J=1,N
         S=0D0
         IF (W(J).NE.0D0) THEN
            DO I=1,M
               S=S+U(I,J)*B(I)
            END DO
            S=S/W(J)
         END IF
         WORK(J)=S
      END DO

*  Multiply by matrix V to get result
      DO J=1,N
         S=0D0
         DO JJ=1,N
            S=S+V(J,JJ)*WORK(JJ)
         END DO
         X(J)=S
      END DO

      END