! Created by EverLookNeverSee@GitHub on 6/11/20
! For more information see FCS/img/Exercise_13.png

program main
    implicit none
    ! declaring variables
    integer :: n, i, j
    real :: tmp_1, tmp_2, tmp_3, tmp_4, tmp_5, corr, numerator, denominator
    real, allocatable, dimension(:) :: x, y
    ! initializing temporary variables
    tmp_1 = 0.0; tmp_2 = 0.0; tmp_3 = 0.0; tmp_4 = 0.0; tmp_5 = 0.0
    ! specifying number of elements in sets
    do
        print *, "Enter the number of elements in sets:"
        read *, n
        if (n <= 0) then
            print *, "You should enter a positive integer number!"
            cycle
        else
            exit
        end if
    end do
    ! allocating memory space to arrays
    allocate(x(n))
    allocate(y(n))
    ! assigning values to sets using user input
    ! x set
    do i = 1, n
        print *, "x(", i, "):"
        read *, x(i)
    end do
    ! y set
    do j = 1, n
        print *, "y(", j, "):"
        read *, y(j)
    end do
    ! --------------------------------------------------------------------
    ! tmp_1
    do i = 1, n
        tmp_1 = tmp_1 + (x(i) * y(i))
    end do
    ! tmp_2
    do i = 1, n
        tmp_2 = tmp_2 + x(i)
    end do
    ! tmp_3
    do i = 1, n
        tmp_3 = tmp_3 + y(i)
    end do
    ! tmp_4
    do i = 1, n
        tmp_4 = tmp_4 + x(i) ** 2
    end do
    ! tmp_5
    do i = 1, n
        tmp_5 = tmp_5 + y(i) ** 2
    end do
    ! --------------------------------------------------------------------
    ! calculating the numerator
    numerator = (n * tmp_1) - (tmp_2 * tmp_3)
    ! calculating denominator
    denominator = sqrt(n * tmp_4 - tmp_2 ** 2) * sqrt(n * tmp_5 - tmp_3 ** 2)
    ! calculating correlation coefficient
    corr = numerator / denominator
    ! printing result
    print *, "Correletion coefficient:", corr
end program main


      function dzasum ( n, zx, incx )

c*********************************************************************72
c
cc DZASUM takes the sum of the absolute values.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
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 complex X(*), the vector.
c
c    Input, integer INCX, the increment between successive entries of X.
c
c    Output, double precision DZASUM, the sum of the absolute values.
c
      implicit none

      double precision dzasum
      integer i
      integer incx
      integer ix
      integer n
      double precision stemp
      double precision zabs1
      double complex zx(*)

      dzasum = 0.0d0
      stemp = 0.0d0
      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      do i = 1,n
        stemp = stemp + zabs1(zx(ix))
        ix = ix + incx
      end do
      dzasum = stemp
      return
c
c        code for increment equal to 1
c
   20 do i = 1,n
        stemp = stemp + zabs1(zx(i))
      end do
      dzasum = stemp
      return
      end
      function dznrm2 ( n, x, incx )

c*********************************************************************72
c
cc DZNRM2 returns the euclidean norm of a vector.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
c
c  Modified:
c
c    07 July 2007
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 complex X(*), the vector.
c
c    Input, integer INCX, the increment between successive entries of X.
c
c    Output, double precision DZNRM2, the norm of the vector.
c
      implicit none

      integer                           incx, n
      double complex x( * )

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

      double precision dznrm2
      integer               ix
      double precision      norm, scale, ssq, temp

      intrinsic             abs, dimag, dble, sqrt

      if( n.lt.1 .or. incx.lt.1 )then
         norm  = zero
      else
         scale = zero
         ssq   = one

         do ix = 1, 1 + ( n - 1 )*incx, incx
            if( dble( x( ix ) ).ne.zero )then
               temp = abs( dble( x( ix ) ) )
               if( scale.lt.temp )then
                  ssq   = one   + ssq*( scale/temp )**2
                  scale = temp
               else
                  ssq   = ssq   +     ( temp/scale )**2
               end if
            end if
            if( dimag( x( ix ) ).ne.zero )then
               temp = abs( dimag( x( ix ) ) )
               if( scale.lt.temp )then
                  ssq   = one   + ssq*( scale/temp )**2
                  scale = temp
               else
                  ssq   = ssq   +     ( temp/scale )**2
               end if
            end if
         end do
         norm  = scale * sqrt( ssq )
      end if

      dznrm2 = norm

      return
      end
      function izamax ( n, zx, incx )

c*********************************************************************72
c
cc IZAMAX finds the index of element having maximum absolute value.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
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 complex X(*), the vector.
c
c    Input, integer INCX, the increment between successive entries of X.
c
c    Output, integer IZAMAX, the index of the element of maximum
c    absolute value.
c
      implicit none

      integer izamax
      double complex zx(*)
      double precision smax
      integer i,incx,ix,n
      double precision zabs1

      izamax = 0
      if( n.lt.1 .or. incx.le.0 )return
      izamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      smax = zabs1(zx(1))
      ix = ix + incx
      do i = 2,n
        if ( smax .lt. zabs1(zx(ix)) ) then
          izamax = i
          smax = zabs1(zx(ix))
        end if
        ix = ix + incx
      end do
      return
c
c        code for increment equal to 1
c
   20 smax = zabs1(zx(1))
      do i = 2,n
        if ( smax .lt. zabs1(zx(i)) ) then
          izamax = i
          smax = zabs1(zx(i))
        end if
      end do

      return
      end
      subroutine zaxpy ( n, za, zx, incx, zy, incy )

c*********************************************************************72
c
cc ZAXPY computes constant times a vector plus a vector.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
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 CX and CY.
c
c    Input, double complex CA, the multiplier of CX.
c
c    Input, double complex CX(*), the first vector.
c
c    Input, integer INCX, the increment between successive entries of CX.
c
c    Input/output, double complex CY(*), the second vector.
c    On output, CY(*) has been replaced by CY(*) + CA * CX(*).
c
c    Input, integer INCY, the increment between successive entries of CY.
c
      implicit none

      double complex zx(*),zy(*),za
      integer i,incx,incy,ix,iy,n
      double precision zabs1
      if(n.le.0)return
      if (zabs1(za) .eq. 0.0d0) return
      if (incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        zy(iy) = zy(iy) + za*zx(ix)
        ix = ix + incx
        iy = iy + incy
      end do
      return
c
c        code for both increments equal to 1
c
   20 do i = 1,n
        zy(i) = zy(i) + za*zx(i)
      end do
      return
      end
      subroutine zcopy ( n, zx, incx, zy, incy )

c*********************************************************************72
c
cc ZCOPY copies a vector, x, to a vector, y.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
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 CX and CY.
c
c    Input, double complex CX(*), the first vector.
c
c    Input, integer INCX, the increment between successive entries of CX.
c
c    Output, double complex CY(*), the second vector.
c
c    Input, integer INCY, the increment between successive entries of CY.
c
      implicit none

      double complex zx(*),zy(*)
      integer i,incx,incy,ix,iy,n
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        zy(iy) = zx(ix)
        ix = ix + incx
        iy = iy + incy
      end do
      return
c
c        code for both increments equal to 1
c
   20 do i = 1,n
        zy(i) = zx(i)
      end do

      return
      end
      function zdotc ( n, zx, incx, zy, incy )

c*********************************************************************72
c
cc ZDOTC forms the dot product of a vector.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
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, double complex CX(*), the first vector.
c
c    Input, integer INCX, the increment between successive entries in CX.
c
c    Input, double complex CY(*), the second vector.
c
c    Input, integer INCY, the increment between successive entries in CY.
c
c    Output, double complex ZDOTC, the conjugated dot product of
c    the corresponding entries of CX and CY.
c
      implicit none

      double complex zx(*),zy(*),ztemp
      double complex zdotc
      integer i,incx,incy,ix,iy,n

      ztemp = (0.0d0,0.0d0)
      zdotc = (0.0d0,0.0d0)
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        ztemp = ztemp + dconjg(zx(ix))*zy(iy)
        ix = ix + incx
        iy = iy + incy
      end do
      zdotc = ztemp
      return
c
c        code for both increments equal to 1
c
   20 do i = 1,n
        ztemp = ztemp + dconjg(zx(i))*zy(i)
      end do

      zdotc = ztemp

      return
      end
      function zdotu ( n, zx, incx, zy, incy )

c*********************************************************************72
c
cc ZDOTU forms the dot product of two vectors.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
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, double complex CX(*), the first vector.
c
c    Input, integer INCX, the increment between successive entries in CX.
c
c    Input, double complex CY(*), the second vector.
c
c    Input, integer INCY, the increment between successive entries in CY.
c
c    Output, double complex ZDOTU, the unconjugated dot product of
c    the corresponding entries of CX and CY.
c
      implicit none

      double complex zx(*),zy(*),ztemp
      double complex zdotu
      integer i,incx,incy,ix,iy,n

      ztemp = (0.0d0,0.0d0)
      zdotu = (0.0d0,0.0d0)
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do i = 1,n
        ztemp = ztemp + zx(ix)*zy(iy)
        ix = ix + incx
        iy = iy + incy
      end do
      zdotu = ztemp
      return
c
c        code for both increments equal to 1
c
   20 do i = 1,n
        ztemp = ztemp + zx(i)*zy(i)
      end do

      zdotu = ztemp

      return
      end
      subroutine zdrot ( n, zx, incx, zy, incy, c, s )

c*********************************************************************72
c
cc ZDROT applies a plane rotation.
c
c  Discussion:
c
c    The cos and sin (c and s) are double precision and the vectors
c    zx and zy are double complex.
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 complex CX(*), one of the vectors to be rotated.
c
c    Input, integer INCX, the increment between successive entries of CX.
c
c    Input/output, double complex CY(*), one of the vectors to be rotated.
c
c    Input, integer INCY, the increment between successive elements of CY.
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 complex zx(1),zy(1),ztemp
      double precision c,s
      integer i,incx,incy,ix,iy,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
c         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
        ztemp = c*zx(ix) + s*zy(iy)
        zy(iy) = c*zy(iy) - s*zx(ix)
        zx(ix) = ztemp
        ix = ix + incx
        iy = iy + incy
      end do
      return
c
c       code for both increments equal to 1
c
   20 do i = 1,n
        ztemp = c*zx(i) + s*zy(i)
        zy(i) = c*zy(i) - s*zx(i)
        zx(i) = ztemp
      end do

      return
      end
      subroutine zdscal ( n, da, zx, incx )

c*********************************************************************72
c
cc ZDSCAL scales a vector by a constant.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
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 SA, the multiplier.
c
c    Input/output, double complex CX(*), the vector to be scaled.
c
c    Input, integer INCX, the increment between successive entries of
c    the vector CX.
c
      implicit none

      double precision da
      integer i
      integer incx
      integer ix
      integer n
      double complex zx(*)

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

      if ( incx .eq. 1 ) then

        do i = 1, n
          zx(i) = dcmplx ( da, 0.0d0 ) * zx(i)
        end do

      else

        ix = 1
        do i = 1, n
          zx(ix) = dcmplx ( da, 0.0d0 ) * zx(ix)
          ix = ix + incx
        end do

      end if

      return
      end
      subroutine zrotg ( ca, cb, c, s )

c*********************************************************************72
c
cc ZROTG generates a Givens rotation.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
c
c    Given values A and B, this routine computes:
c
c    If A = 0:
c
c      R = B
c      C = 0
c      S = (1,0).
c
c    If A /= 0:
c
c      ALPHA = A / abs ( A )
c      NORM  = sqrt ( ( abs ( A ) )^2 + ( abs ( B ) )^2 )
c      R     = ALPHA * NORM
c      C     = abs ( A ) / NORM
c      S     = ALPHA * conj ( B ) / NORM
c
c    In either case, the computed numbers satisfy the equation:
c
c    (         C    S ) * ( A ) = ( R )
c    ( -conj ( S )  C )   ( B ) = ( 0 )
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 complex CA, on input, the value A.  On output,
c    the value R.
c
c    Input, double complex CB, the value B.
c
c    Output, double precision C, the cosine of the
c    Givens rotation.
c
c    Output, double complex S, the sine of the
c    Givens rotation.
c
      implicit none

      double complex ca,cb,s
      double precision c
      double precision norm,scale
      double complex alpha

      if (cdabs(ca) .eq. 0.0d0) then
        c = 0.0d0
        s = (1.0d0,0.0d0)
        ca = cb
      else
        scale = cdabs(ca) + cdabs(cb)
        norm = scale*dsqrt((cdabs(ca/dcmplx(scale,0.0d0)))**2 +
     &                     (cdabs(cb/dcmplx(scale,0.0d0)))**2)
        alpha = ca /cdabs(ca)
        c = cdabs(ca) / norm
        s = alpha * dconjg(cb) / norm
        ca = alpha * norm
      end if

      return
      end
      subroutine zscal ( n, za, zx, incx )

c*********************************************************************72
c
cc ZSCAL scales a vector by a constant.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
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 complex CA, the multiplier.
c
c    Input/output, double complex CX(*), the vector to be scaled.
c
c    Input, integer INCX, the increment between successive entries of CX.
c
      implicit none

      double complex za,zx(*)
      integer i,incx,ix,n

      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
c
c        code for increment not equal to 1
c
      ix = 1
      do i = 1,n
        zx(ix) = za*zx(ix)
        ix = ix + incx
      end do

      return
c
c        code for increment equal to 1
c
   20 do i = 1,n
        zx(i) = za*zx(i)
      end do

      return
      end
      subroutine zswap ( n, zx, incx, zy, incy )

c*********************************************************************72
c
cc ZSWAP interchanges two vectors.
c
c  Discussion:
c
c    This routine uses double precision complex arithmetic.
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 complex CX(*), one of the vectors to swap.
c
c    Input, integer INCX, the increment between successive entries of CX.
c
c    Input/output, double complex CY(*), one of the vectors to swap.
c
c    Input, integer INCY, the increment between successive elements of CY.
c
      implicit none

      double complex zx(*),zy(*),ztemp
      integer i,incx,incy,ix,iy,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
c         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
        ztemp = zx(ix)
        zx(ix) = zy(iy)
        zy(iy) = ztemp
        ix = ix + incx
        iy = iy + incy
      end do

      return
c
c       code for both increments equal to 1
c
   20 do i = 1,n
        ztemp = zx(i)
        zx(i) = zy(i)
        zy(i) = ztemp
      end do

      return
      end


subroutine fem1d_heat_steady ( n, a, b, ua, ub, k, f, x, u )

!*****************************************************************************80
!
!! FEM1D_HEAT_STEADY solves the steady 1D heat equation with finite elements.
!
!  Discussion:
!
!    The program uses the finite element method, with piecewise linear basis
!    functions to solve the steady state heat equation in one dimension.
!
!    The problem is defined on the region A <= x <= B.
!
!    The following differential equation is imposed between A and B:
!
!      - d/dx k(x) du/dx = f(x)
!
!    where k(x) and f(x) are given functions.
!
!    At the boundaries, the following conditions are applied:
!
!      u(A) = UA
!      u(B) = UB
!
!    A set of N equally spaced nodes is defined on this
!    interval, with A = X(1) < X(2) < ... < X(N) = B.
!
!    At each node I, we associate a piecewise linear basis function V(I,X),
!    which is 0 at all nodes except node I.  This implies that V(I,X) is
!    everywhere 0 except that
!
!    for X(I-1) <= X <= X(I):
!
!      V(I,X) = ( X - X(I-1) ) / ( X(I) - X(I-1) )
!
!    for X(I) <= X <= X(I+1):
!
!      V(I,X) = ( X(I+1) - X ) / ( X(I+1) - X(I) )
!
!    We now assume that the solution U(X) can be written as a linear
!    sum of these basis functions:
!
!      U(X) = sum ( 1 <= J <= N ) U(J) * V(J,X)
!
!    where U(X) on the left is the function of X, but on the right,
!    is meant to indicate the coefficients of the basis functions.
!
!    To determine the coefficient U(J), we multiply the original
!    differential equation by the basis function V(J,X), and use
!    integration by parts, to arrive at the I-th finite element equation:
!
!        Integral K(X) * U'(X) * V'(I,X) dx = Integral F(X) * V(I,X) dx
!
!    We note that the functions U(X) and U'(X) can be replaced by
!    the finite element form involving the linear sum of basis functions,
!    but we also note that the resulting integrand will only be nonzero
!    for terms where J = I - 1, I, or I + 1.
!
!    By writing this equation for basis functions I = 2 through N - 1,
!    and using the boundary conditions, we have N linear equations
!    for the N unknown coefficients U(1) through U(N), which can
!    be easily solved.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    07 April 2011
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of nodes.
!
!    Input, real ( kind = 8 ) A, B, the left and right endpoints.
!
!    Input, real ( kind = 8 ) UA, UB, the prescribed value of U at A and B.
!
!    Input, external K, a function which evaluates k(x);
!
!    Input, external F, a function which evaluates f(x);
!
!    Input, real ( kind = 8 ) X(N), the mesh points.
!
!    Output, real ( kind = 8 ) U(N), the finite element coefficients, which
!    are also the value of the computed solution at the mesh points.
!
  implicit none

  integer ( kind = 4 ) n
  integer ( kind = 4 ), parameter :: quad_num = 2

  real ( kind = 8 ) a
  real ( kind = 8 ) abscissa(quad_num)
  real ( kind = 8 ) al
  real ( kind = 8 ) am
  real ( kind = 8 ) ar
  real ( kind = 8 ) amat(n,n)
  real ( kind = 8 ) b
  real ( kind = 8 ) bm
  real ( kind = 8 ) bvec(n)
  real ( kind = 8 ), external :: f
  real ( kind = 8 ) fxq
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ierror
  real ( kind = 8 ), external :: k
  real ( kind = 8 ) kxq
  integer ( kind = 4 ) q
  real ( kind = 8 ) weight(quad_num)
  real ( kind = 8 ) wq
  real ( kind = 8 ) u(n)
  real ( kind = 8 ) ua
  real ( kind = 8 ) ub
  real ( kind = 8 ) vl
  real ( kind = 8 ) vlp
  real ( kind = 8 ) vm
  real ( kind = 8 ) vmp
  real ( kind = 8 ) vr
  real ( kind = 8 ) vrp
  real ( kind = 8 ) x(n)
  real ( kind = 8 ) xl
  real ( kind = 8 ) xm
  real ( kind = 8 ) xq
  real ( kind = 8 ) xr
!
!  Define a quadrature rule on the interval [-1,+1].
!
  abscissa(1) = -0.577350269189625764509148780502D+00
  abscissa(2) = +0.577350269189625764509148780502D+00
  weight(1) = 1.0D+00
  weight(2) = 1.0D+00
!
!  Zero out the matrix and right hand side.
!
  amat(1:n,1:n) = 0.0D+00
  bvec(1:n) = 0.0D+00
!
!  Equation 1 is the left boundary condition, U(A) = UA;
!
  amat(1,1) = 1.0D+00
  bvec(1) = ua
!
!  Equation I involves the basis function at node I.
!  This basis function is nonzero from X(I-1) to X(I+1).
!  Equation I looks like this:
!
!    Integral K(X) U'(X) V'(I,X)
!           + C(X) * U(X) V(I,X) dx
!  = Integral F(X) V(I,X) dx
!
!  Then, we realize that U(X) = sum ( 1 <= J <= N ) U(J) * V(J,X),
!  (U(X) means the function; U(J) is the coefficient of V(J,X) ).
!
!  The only V functions that are nonzero when V(I,X) is nonzero are
!  V(I-1,X) and V(I+1,X).
!
!  Let's use the shorthand
!
!    VL(X) = V(I-1,X)
!    VM(X) = V(I,X)
!    VR(X) = V(I+1,X)
!
!  So our equation becomes
!
!    Integral K(X) [ VL'(X) U(I-1) + VM'(X) U(I) + VR'(X) U(I+1) ] * VM'(X) dx
!  = Integral F(X) VM(X) dx.
!
!
!
!  This is actually a set of N-2 linear equations for the N coefficients U.
!
!  Now gather the multipliers of U(I-1) to get the matrix entry A(I,I-1),
!  and so on.
!
  do i = 2, n - 1
!
!  Get the left, right and middle coordinates.
!
    xl = x(i-1)
    xm = x(i)
    xr = x(i+1)
!
!  Make temporary variables for A(I,I-1), A(I,I), A(I,I+1) and B(I).
!
    al = 0.0D+00
    am = 0.0D+00
    ar = 0.0D+00
    bm = 0.0D+00
!
!  We approximate the integrals by using a weighted sum of
!  the integrand values at quadrature points.
!
    do q = 1, quad_num
!
!  Integrate over the LEFT interval, between XL and XM, where:
!
!  VL(X) = ( XM - X       ) / ( XM - XL )
!  VM(X) = (      X  - XL ) / ( XM - XL )
!  VR(X) = 0
!
!  VL'(X) =             - 1 / ( XM - XL )
!  VM'(X) =             + 1 / ( XM - XL )
!  VR'(X) = 0
!
      xq = ( ( 1.0D+00 - abscissa(q) ) * xl   &
           + ( 1.0D+00 + abscissa(q) ) * xm ) &
           /   2.0D+00

      wq = weight(q) * ( xm - xl ) / 2.0D+00

      vl =  ( xm - xq ) / ( xm - xl )
      vlp =  - 1.0D+00  / ( xm - xl )

      vm =  ( xq - xl ) / ( xm - xl )
      vmp =  + 1.0D+00  / ( xm - xl )

      vr =  0.0D+00
      vrp = 0.0D+00

      kxq = k ( xq )
      fxq = f ( xq )

      al = al + wq * ( kxq * vlp * vmp )
      am = am + wq * ( kxq * vmp * vmp )
      ar = ar + wq * ( kxq * vrp * vmp )
      bm = bm + wq * ( fxq * vm )
!
!  Integrate over the RIGHT interval, between XM and XR, where:
!
!  VL(X) = 0
!  VM(X) = ( XR - X       ) / ( XR - XM )
!  VR(X) = (      X  - XM ) / ( XR - XM )
!
!  VL'(X) = 0
!  VM'(X) =             - 1 / ( XR - XM )
!  VR'(X) =             + 1 / ( XR - XM )
!
      xq = ( ( 1.0D+00 - abscissa(q) ) * xm   &
           + ( 1.0D+00 + abscissa(q) ) * xr ) &
           /   2.0D+00

      wq = weight(q) * ( xr - xm ) / 2.0D+00

      vl = 0.0D+00
      vlp = 0.0D+00

      vm = ( xr - xq ) / ( xr - xm )
      vmp = - 1.0D+00  / ( xr - xm )

      vr = ( xq - xm ) / ( xr - xm )
      vrp =  1.0D+00   / ( xr - xm )

      kxq = k ( xq )
      fxq = f ( xq )

      al = al + wq * ( kxq * vlp * vmp )
      am = am + wq * ( kxq * vmp * vmp )
      ar = ar + wq * ( kxq * vrp * vmp )
      bm = bm + wq * ( fxq * vm )

    end do

    amat(i,i-1) = al
    amat(i,i)   = am
    amat(i,i+1) = ar
    bvec(i)     = bm

  end do
!
!  Equation N is the right boundary condition, U(B) = UB;
!
  amat(n,n) = 1.0D+00
  bvec(n) = ub
!
!  Solve the linear system.
!
!  call r8mat_print ( n, n, amat, '  Matrix A:' )

  call r8mat_solve2 ( n, amat, bvec, u, ierror )

  return
end
subroutine r8mat_print ( m, n, a, title )

!*****************************************************************************80
!
!! R8MAT_PRINT prints an R8MAT.
!
!  Discussion:
!
!    An R8MAT is an array of R8 values.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    12 September 2004
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, the number of rows in A.
!
!    Input, integer ( kind = 4 ) N, the number of columns in A.
!
!    Input, real ( kind = 8 ) A(M,N), the matrix.
!
!    Input, character ( len = * ) TITLE, a title.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  character ( len = * ) title

  call r8mat_print_some ( m, n, a, 1, 1, m, n, title )

  return
end
subroutine r8mat_print_some ( m, n, a, ilo, jlo, ihi, jhi, title )

!*****************************************************************************80
!
!! R8MAT_PRINT_SOME prints some of an R8MAT.
!
!  Discussion:
!
!    An R8MAT is an array of R8 values.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    10 September 2009
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, N, the number of rows and columns.
!
!    Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed.
!
!    Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print.
!
!    Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print.
!
!    Input, character ( len = * ) TITLE, a title.
!
  implicit none

  integer ( kind = 4 ), parameter :: incx = 5
  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  real ( kind = 8 ) a(m,n)
  character ( len = 14 ) ctemp(incx)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) i2hi
  integer ( kind = 4 ) i2lo
  integer ( kind = 4 ) ihi
  integer ( kind = 4 ) ilo
  integer ( kind = 4 ) inc
  integer ( kind = 4 ) j
  integer ( kind = 4 ) j2
  integer ( kind = 4 ) j2hi
  integer ( kind = 4 ) j2lo
  integer ( kind = 4 ) jhi
  integer ( kind = 4 ) jlo
  character ( len = * ) title

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) trim ( title )

  if ( m <= 0 .or. n <= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  (None)'
    return
  end if

  do j2lo = max ( jlo, 1 ), min ( jhi, n ), incx

    j2hi = j2lo + incx - 1
    j2hi = min ( j2hi, n )
    j2hi = min ( j2hi, jhi )

    inc = j2hi + 1 - j2lo

    write ( *, '(a)' ) ' '

    do j = j2lo, j2hi
      j2 = j + 1 - j2lo
      write ( ctemp(j2), '(i8,6x)' ) j
    end do

    write ( *, '(''  Col   '',5a14)' ) ctemp(1:inc)
    write ( *, '(a)' ) '  Row'
    write ( *, '(a)' ) ' '

    i2lo = max ( ilo, 1 )
    i2hi = min ( ihi, m )

    do i = i2lo, i2hi

      do j2 = 1, inc

        j = j2lo - 1 + j2

        if ( a(i,j) == real ( int ( a(i,j) ), kind = 8 ) ) then
          write ( ctemp(j2), '(f8.0,6x)' ) a(i,j)
        else
          write ( ctemp(j2), '(g14.6)' ) a(i,j)
        end if

      end do

      write ( *, '(i5,a,5a14)' ) i, ':', ( ctemp(j), j = 1, inc )

    end do

  end do

  return
end
subroutine r8mat_solve2 ( n, a, b, x, ierror )

!*****************************************************************************80
!
!! R8MAT_SOLVE2 computes the solution of an N by N linear system.
!
!  Discussion:
!
!    An R8MAT is an array of R8 values.
!
!    The linear system may be represented as
!
!      A*X = B
!
!    If the linear system is singular, but consistent, then the routine will
!    still produce a solution.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    29 October 2005
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of equations.
!
!    Input/output, real ( kind = 8 ) A(N,N).
!    On input, A is the coefficient matrix to be inverted.
!    On output, A has been overwritten.
!
!    Input/output, real ( kind = 8 ) B(N).
!    On input, B is the right hand side of the system.
!    On output, B has been overwritten.
!
!    Output, real ( kind = 8 ) X(N), the solution of the linear system.
!
!    Output, integer ( kind = 4 ) IERROR.
!    0, no error detected.
!    1, consistent singularity.
!    2, inconsistent singularity.
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a(n,n)
  real ( kind = 8 ) amax
  real ( kind = 8 ) b(n)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ierror
  integer ( kind = 4 ) imax
  integer ( kind = 4 ) ipiv(n)
  integer ( kind = 4 ) j
  integer ( kind = 4 ) k
  real ( kind = 8 ) x(n)

  ierror = 0

  ipiv(1:n) = 0
  x(1:n) = 0.0D+00
!
!  Process the matrix.
!
  do k = 1, n
!
!  In column K:
!    Seek the row IMAX with the properties that:
!      IMAX has not already been used as a pivot;
!      A(IMAX,K) is larger in magnitude than any other candidate.
!
    amax = 0.0D+00
    imax = 0
    do i = 1, n
      if ( ipiv(i) == 0 ) then
        if ( amax < abs ( a(i,k) ) ) then
          imax = i
          amax = abs ( a(i,k) )
        end if
      end if
    end do
!
!  If you found a pivot row IMAX, then,
!    eliminate the K-th entry in all rows that have not been used for pivoting.
!
    if ( imax /= 0 ) then

      ipiv(imax) = k
      a(imax,k+1:n) = a(imax,k+1:n) / a(imax,k)
      b(imax) = b(imax) / a(imax,k)
      a(imax,k) = 1.0D+00

      do i = 1, n

        if ( ipiv(i) == 0 ) then
          a(i,k+1:n) = a(i,k+1:n) - a(i,k) * a(imax,k+1:n)
          b(i) = b(i) - a(i,k) * b(imax)
          a(i,k) = 0.0D+00
        end if

      end do

    end if

  end do
!
!  Now, every row with nonzero IPIV begins with a 1, and
!  all other rows are all zero.  Begin solution.
!
  do j = n, 1, -1

    imax = 0
    do k = 1, n
      if ( ipiv(k) == j ) then
        imax = k
      end if
    end do

    if ( imax == 0 ) then

      x(j) = 0.0D+00

      if ( b(j) == 0.0D+00 ) then
        ierror = 1
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8MAT_SOLVE2 - Warning:'
        write ( *, '(a,i8)' ) '  Consistent singularity, equation = ', j
      else
        ierror = 2
        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'R8MAT_SOLVE2 - Error:'
        write ( *, '(a,i8)' ) '  Inconsistent singularity, equation = ', j
      end if

    else

      x(j) = b(imax)

      do i = 1, n
        if ( i /= imax ) then
          b(i) = b(i) - a(i,j) * x(j)
        end if
      end do

    end if

  end do

  return
end
subroutine r8vec_even ( n, alo, ahi, a )

!*****************************************************************************80
!
!! R8VEC_EVEN returns an R8VEC of evenly spaced values.
!
!  Discussion:
!
!    An R8VEC is a vector of R8's.
!
!    If N is 1, then the midpoint is returned.
!
!    Otherwise, the two endpoints are returned, and N-2 evenly
!    spaced points between them.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    09 December 2004
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of values.
!
!    Input, real ( kind = 8 ) ALO, AHI, the low and high values.
!
!    Output, real ( kind = 8 ) A(N), N evenly spaced values.
!    Normally, A(1) = ALO and A(N) = AHI.
!    However, if N = 1, then A(1) = 0.5*(ALO+AHI).
!
  implicit none

  integer ( kind = 4 ) n

  real ( kind = 8 ) a(n)
  real ( kind = 8 ) ahi
  real ( kind = 8 ) alo
  integer ( kind = 4 ) i

  if ( n == 1 ) then

    a(1) = 0.5D+00 * ( alo + ahi )

  else

    do i = 1, n
      a(i) = ( real ( n - i,     kind = 8 ) * alo   &
             + real (     i - 1, kind = 8 ) * ahi ) &
             / real ( n     - 1, kind = 8 )
    end do

  end if

  return
end
subroutine timestamp ( )

!*****************************************************************************80
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!  Example:
!
!    31 May 2001   9:45:54.872 AM
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 May 2013
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none

  character ( len = 8 ) ampm
  integer ( kind = 4 ) d
  integer ( kind = 4 ) h
  integer ( kind = 4 ) m
  integer ( kind = 4 ) mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer ( kind = 4 ) n
  integer ( kind = 4 ) s
  integer ( kind = 4 ) values(8)
  integer ( kind = 4 ) y

  call date_and_time ( values = values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 2015 Adrian Martinez Vargas                            %
!                                                                      %
! This software may be modified and distributed under the terms        %
! of the MIT license.  See the LICENSE.txt file for details.           %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

subroutine rotscale(X,Y,Z,nd,X0,Y0,Z0,ang1,ang2,ang3,anis1,anis2,invert,Xr,Yr,Zr)
    !-----------------------------------------------------------------------

    !              Rotate coordinates
    !              ******************

    ! This is implemented as in http://www.ccgalberta.com/ccgresources/report06/2004-403-angle_rotations.pdf

    ! INPUT PARAMETERS:

    !   X,Y, Z           X,Y,Z arrays with coordinates
    !   nd               number of data points
    !   X0,Y0,Z0         New origin of coordinate
    !   ang1             Azimuth angle for principal direction
    !   ang2             Dip angle for principal direction
    !   ang3             Third rotation angle
    !   anis1            First anisotropy ratio
    !   anis2            Second anisotropy ratio
    !   invert           If 0 do rotation, if 1 invert rotation

    ! Rerurn
    !   Xr,Yr,Zr         New rotated and scaled X,Y,Z arrays with coordinates

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

    implicit none

    ! input
    real*8, intent(in), dimension(nd) ::X,Y,Z
    real*8, intent(in) :: ang1,ang2,ang3,anis1,anis2, X0,Y0,Z0
    integer, intent(in) :: invert, nd

    ! output
    real*8, intent(out), dimension(nd) ::Xr,Yr,Zr

    ! internal variables
    real*8 ::   alpha, beta, theta, sina,sinb,sint, &
                cosa,cosb,cost,afac1,afac2, &
                X1,Y1,Z1, X2,Y2,Z2
    integer :: i

    !parameters
    real*8 :: DEG2RAD,EPSLON

    DEG2RAD=3.141592654/180.0
    EPSLON=1.e-20

    alpha = ang1 * DEG2RAD
    beta  = ang2 * DEG2RAD
    theta = ang3 * DEG2RAD

    ! Get the required sines and cosines:

    sina  = dble(sin(alpha))
    sinb  = dble(sin(beta))
    sint  = dble(sin(theta))
    cosa  = dble(cos(alpha))
    cosb  = dble(cos(beta))
    cost  = dble(cos(theta))

    ! Construct the rotation matrix in the required memory:

    afac1 = 1.0 / dble(max(anis1,EPSLON))
    afac2 = 1.0 / dble(max(anis2,EPSLON))

    if (invert == 0) then
        do i=1,nd
            !shift
            X1 = X(i)-X0
            Y1 = Y(i)-Y0
            Z1 = Z(i)-Z0
            ! rotate using equation 4 on http://www.ccgalberta.com/ccgresources/report06/2004-403-angle_rotations.pdf
            X2= (cosa*cost+sina*sinb*sint)*X1 + (-sina*cost+cosa*sinb*sint)*Y1 +(-cosb*sint)*Z1
            Y2=                (sina*cosb)*X1 +                 (cosa*cosb)*Y1 +      (sinb)*Z1
            Z2= (cosa*sint-sina*sinb*cost)*X1 + (-sina*sint-cosa*sinb*cost)*Y1 + (cosb*cost)*Z1
            !rescale
            Xr(i)= X2
            Yr(i)= Y2*afac1
            Zr(i)= Z2*afac2
        end do
    else
        do i=1,nd
            !rescale
            X1 = X(i)
            Y1 = Y(i)/afac1
            Z1 = Z(i)/afac2
            ! rotate using equation 5 on http://www.ccgalberta.com/ccgresources/report06/2004-403-angle_rotations.pdf
            X2= (cosa*cost+sina*sinb*sint)*X1 + (sina*cosb)*Y1 + (cosa*sint-sina*sinb*cost)*Z1
            Y2=(-sina*cost+cosa*sinb*sint)*X1 + (cosa*cosb)*Y1 +(-sina*sint-cosa*sinb*cost)*Z1
            Z2=               (-cosb*sint)*X1 +      (sinb)*Y1 +                (cosb*cost)*Z1
            !shift
            Xr(i) = X2+X0
            Yr(i) = Y2+Y0
            Zr(i) = Z2+Z0
        end do
    end if

    ! Return to calling program:
    return

end subroutine rotscale


subroutine bkfilter(n, y, up, dn, k, ybp, yt)

! Aubhik 20.02.2005
!
! Baxter and King (1999) Band-Pass filter
!
! y is a data vector of length n
! ybp is the band pass filtered series, with 0.0 for the first and last k observations
! n is the length of the data vector y
! up is the lower frequency
!	for example, the business cycle band will have up = 6 for quarterly data
!	and up = 1.5 for annual data
! dn is the higher frequency
!	for example, the business cycle band will have dn = 32 for quarterly data
!	and dn = 8 for annual data
! k is the number of leads and lags used by the symmetric moving-average
!	representation of the band pass filter.  Baxter and King (1999) find
!	that k = 12 is a practical choice.
!
! Algorithm provided by Bob King.  This subroutine is the Fortran 90 version of
! bpf.m and filtk.m written by Baxter and King (1999).  The band pass filter is
! a moving average involving 2k+1 terms.  The weights are symmetric and calculated
! in akvec.

implicit none

integer n, up, dn, k
real y(n), ybp(n), yt(n)

integer j
real pi, omlbar, omubar, kr, kj, theta
real akvec(k+1), avec(2*k+1), tvec(2*k+1)

intent(in):: n, up, dn, k, y
intent(out):: ybp, yt

pi = 2.0*acos(0.0)

omlbar = 2.0*pi/dble(dn)
omubar = 2.0*pi/dble(up)

akvec = 0.0
avec = 0.0

kr = dble(k)

akvec(1) = (omubar - omlbar)/pi

do j = 1, k
    kj = dble(j)
    akvec(j+1) = (dsin(dble(kj*omubar)) - dsin(dble(kj*omlbar)))/(kj*pi)
end do

theta = akvec(1) + 2.0*sum(akvec(2:k+1))
theta = -1.0*(theta/(2.0*kr + 1.0))

akvec = akvec + theta

avec(k+1) = akvec(1)

do j = 1, k
    avec(k+1 - j) = akvec(j+1)
    avec(k+1 + j) = akvec(j+1)
end do

do j = 1, k*2+1
    tvec(j) = 1.0 - avec(j)
end do

ybp = 0.0
yt = 0.0

do j = k + 1, n - k
    ybp(j) = dot_product(avec, y(j - k: j + k))
    yt(j) = dot_product(tvec, y(j - k: j + k))
end do

end subroutine bkfilter


subroutine distancef(vart, varf, ntt, ntf, nxy, dist)
! Estimate the Euclidean distance between the given atmospheric circulation
! variable, say X, daily or monthly mean and all other daily or monthly means within the training period
!
!
! INPUT->  vart(nxy,ntt)      : X array for all months/days of the training period
!          varf(nxy,ntf)      : X array for the month/day under scrutiny for the analogue search
!          ntt                : number of months/days in the training period
!          ntf                : number of months/days under scrutiny for the analogue search
!          nxy                : number of gridpoints
!
! OUTPUT-> dist(ntf,ntt)      : distance array
!
!
  implicit none
   integer                     ::ntt, ntf, nxy
   real                        vart(nxy, ntt), varf(nxy, ntf), dist(ntf, ntt)
   integer                     ::n, m

   !$OMP PARALLEL DO PRIVATE(m)
   do n=1,ntt

      do m=1,ntf
         dist(m,n)              = sqrt(sum(( vart(:,n) - varf(:,m) )**2))
      end do

   end do
   !$OMP END PARALLEL DO

end subroutine distancef


c     ===================================
c     MAIN PROGRAM
c		This program takes a function and
c		computes its definite integral in
c		a region (a, b)
c     ===================================
      program main

c	  Variables
      real*8 a, b, h, hn, error, conv, res, reslast, sum, x
      real*8 f, df2, df4
      integer n, choice, i, j, l
      j = 1
      conv = 1

c     Parameters
c		defining the region to integrate
      a = 0.0d0
      b = 1.0d0

c     User's choice of polynomial order
1     write(*,*) 'Choose the order of the polynomial (1, 2, or 3)'
      read(*,*) choice

      if ((choice.ne.1) .and. (choice.NE.2) .and. (choice.NE.3)) then
        write(*,*) '--- not supported choice ---'
        go to 1
      endif
      if (choice .eq. 1) then
        go to 10
      endif
      if (choice .eq. 2) then
        go to 20
      endif
      if (choice .eq. 3) then
        go to 30
      endif
c     end of polynomial choice

c     ---------------------------------
c	  1st degree polynomial - Trapezoid
c     ---------------------------------
10    continue
      write(*,*) 'Method of choice: Trapezoid (1st degree polynomial)'
c	  Starting parameters
      n = 2
      l = 2

15    continue
      res = 0
      sum = 0
      x = a
      hn = h(a,b,n)

c     loop to calculate f0 + 2f1 + 2f2 + ... + 2fn-1 + fn
      i = 1
11    continue
      if (i.gt.1) then
        x = x + hn
      endif
      if (i.eq.1 .or. i.eq.n) then
        sum = sum + f(x)
      else
        sum = sum + 2 * f(x)
      endif
      i = i + 1
c		ending of loop
      if (i.lt.(n+1)) then
        go to 11
      endif

c	  Calculation of the result
      res = sum * (hn/2.0d0)

c     Use of Romberg's method
      if (j.gt.1) then
        reslast = res
        res = res - (res - reslast)/(l**2 - 1)
        conv = reslast - res
      endif

c	  Calculation of the error
      error = - (1.0d0/12.0d0) * hn * (b-a) * df2( (b-a)/2 )

      if (error.gt.1.0d-9 .or. abs(conv).gt.1.0d-9) then
        j = j + 1
        n = n * l
        go to 15
      endif
      go to 99
c	  End of Trapezoid

c     -------------------------------
c	  2nd degree polynomial - Simpson
c     -------------------------------
20    continue
      write(*,*) 'Method of choice: Simpson (2nd degree polynomial)'
c	  Starting parameters
      n = 2
      l = 2

25    continue
      res = 0
      sum = 0
      x = a
      hn = h(a,b,n)

c     loop to calculate f1 + 4f2 + f3 + ... + fn-1 + 4fn + fn+1
      i = 1
21    continue
      if (i.gt.1) then
        x = x + hn
      endif
      if (i.eq.1 .or. i.eq.n) then
        sum = sum + f(x)
      elseif (mod(i,2).eq.0) then
        sum = sum + 4 * f(x)
      else
        sum = sum + 2 * f(x)
      endif
      i = i + 1
c		ending of loop
      if (i.lt.(n+1)) then
        go to 21
      endif

c	  Calculation of the result
      res = sum * (hn/3.0d0)

c     Use of Romberg's method
      if (j.gt.1) then
        reslast = res
        res = res - (res - reslast)/(l**4 - 1)
        conv = reslast - res
      endif

c	  Calculation of the error
      error = - (1.0d0/80.0d0) * (hn**4) * (b-a) * df4( (b-a)/2 )

      if (error.gt.1.0d-9 .or. abs(conv).gt.1.0d-9) then
        j = j + 1
        n = n * l
        go to 25
      endif

      go to 99
c	  End of Simpson

c     -----------------------------------
c	  3rd degree polynomial - Simpson 3/8
c     -----------------------------------
30    continue
      write(*,*) 'Method of choice: Simpson 3/8 (3rd degree polynomial)'
c	  Starting parameters
      n = 3
      l = 2

35    continue
      res = 0
      sum = 0
      x = a
      hn = h(a,b,n)

c     loop to calculate f0 + 2f1 + 2f2 + ... + 2fn-1 + fn
      i = 1
31    continue
      if (i.gt.1) then
        x = x + hn
      endif
      if (i.eq.1 .or. i.eq.n) then
        sum = sum + f(x)
      elseif (mod(i,3).eq.1) then
        sum = sum + 2 * f(x)
      else
        sum = sum + 3 * f(x)
      endif
      i = i + 1
c		ending of loop
      if (i.lt.(n+1)) then
        go to 31
      endif

c	  Calculation of the result
      res = sum * (3.0d0*hn/8.0d0)

c     Use of Romberg's method
      if (j.gt.1) then
        reslast = res
        res = res - (res - reslast)/(l**4 - 1)
        conv = reslast - res
      endif

c	  Calculation of the error
      error = - (1.0d0/12.0d0) * hn * (b-a) * df2( (b-a)/2 )

      if (error.gt.1.0d-9 .or. abs(conv).gt.1.0d-9) then
        j = j + 1
        n = n * l
        go to 35
      endif
      go to 99
c 	  End of Simpson 3/8

99    continue
      write(*,*) '-----------------------------------'
      write(*,*) 'number of points: ', n
      write(*,*) 'result: ', res
      write(*,*) 'error', error
      write(*,*) 'convergence', conv
      end

c     =========================================
c	  FUNCTION
c		Definition of the function to integrate
c     =========================================
      real*8 function f(x)
      real*8 x

      f = log(x+2.0d-1)

      return
      end

c     =============================================
c	  FUNCTION
c		Definition of the function's 2nd derivative
c     =============================================
      real*8 function df2(x)
      real*8 x

      df2 = - 1.0d0 / (x + 2.0d-1)**2

      return
      end

c     =============================================
c	  FUNCTION
c		Definition of the function's 4th derivative
c     =============================================
      real*8 function df4(x)
      real*8 x

      df4 = - 6.0d0 / (x + 2.0d-1)**4

      return
      end

c     ==============================================
c	  FUNCTION
c		calculating the steps from the needed points
c     ==============================================
      real*8 function h(a,b,n)
      real*8 a, b
      integer n

      h = (b-a)/(n-1)

      return
      end

computational math/numerical integral calculation - differential equation integration 1.(a2).f


      subroutine cqdrtc(Coef,Sol,NSol)
c     Combutes the zeros of a quadratic polynomial
ccccccccccccccccccccccccccccccccccccccccccccccccc
c     Input
c     Coef - array of coefficients
      COMPLEX*16 Coef(3)
ccccccccccccccccccccccccccccccccccccccccccccccccc
c     Output
c     Sol  - Array of solutions
c     NSol - # of solutions (only one if Coef(1) = 0 etc.)
c     NSol = -1 means a and b are zero
      COMPLEX*16 Sol(2)
      INTEGER NSol
ccccccccccccccccccccccccccccccccccccccccccccccccc
c     Local Variables
      COMPLEX*16 q, Sqrt
      DOUBLE PRECISION Sgn, Root

      IF(Coef(1).eq.0.d0) THEN
         IF(Coef(2).eq.0.d0) THEN
            NSol = -1
            RETURN
         ELSE
            NSol = 1
            Sol(1) = -Coef(3)/Coef(2)
         END IF
      ELSE
         NSol = 2
         Root = DBLE(Sqrt(Coef(2)**2-4.d0*Coef(1)*Coef(3)))
         Sgn  = SIGN(DBLE(CONJG(Coef(2))*Root),1.d0)
         q    = -0.5d0*(Coef(2) + Sgn*Root)

         Sol(1) = q/Coef(1)
         Sol(2) = Coef(3)/q
      END IF

      RETURN
      END

      subroutine ccubic(Coef,Sol,NSol)
c     Combutes the zeros of a cubic polynomial
ccccccccccccccccccccccccccccccccccccccccccccccccc
c     Input
c     Coef - array of coefficients
      COMPLEX*16 Coef(4)
ccccccccccccccccccccccccccccccccccccccccccccccccc
c     Output
c     Sol  - Array of solutions
c     NSol - # of solutions (only one if Coef(1) = 0 etc.)
c     NSol = -1 means a, b, and c are zero
      COMPLEX*16 Sol(4)
      INTEGER NSol
ccccccccccccccccccccccccccccccccccccccccccccccccc
c     Local Variables
      COMPLEX*16 P1, P2, Q, R, Coef2(3), a, b, c
      DOUBLE PRECISION Sgn, Theta
c     PARAMETERS
      COMPLEX*16 I
      PARAMETER(I = (0.d0, 1.d0))
      DOUBLE PRECISION Pi
      PARAMETER(Pi = 3.141592653589793238462643d0)

      IF(Coef(1).eq.0.d0) THEN
         Coef2(1) = Coef(2)
         Coef2(2) = Coef(3)
         Coef2(3) = Coef(4)
         CALL CQdrtc(Coef2,Sol,NSol)
      ELSE
         a = Coef(2)/Coef(1)
         b = Coef(3)/Coef(1)
         c = Coef(4)/Coef(1)
         NSol = 3
         Q = (a**2 - 3.d0*b)/9.d0
         R = (2.d0*a**3 - 9.d0*a*b + 27.d0*c)/54.d0

         IF(((DIMAG(Q).eq.0.d0).and.(DIMAG(R).eq.0.d0)).and.
     &        (DIMAG(R**2).lt.DIMAG(Q**3))) THEN
            Theta = ACOS (DBLE(R/SQRT(Q**3)))
            Sol(1) = -2*SQRT(Q)*Cos(Theta/3.d0) - a/3.d0
            Sol(2) = -2*SQRT(Q)*Cos((Theta+2.d0*Pi)/3.d0) - a/3.d0
            Sol(3) = -2*SQRT(Q)*Cos((Theta-2.d0*Pi)/3.d0) - a/3.d0
         ELSE
            Sgn = SIGN(1.d0, DBLE(CONJG(R)*SQRT(R**2-Q**3)))
            P1 = -(R + Sgn*SQRT(R**2-Q**3))**(1.d0/3.d0)
            IF(P1.eq.0.d0) THEN
               P2 = 0.d0
            ELSE
               P2 = Q/P1
            END IF
            Sol(1) = (P1 + P2) - a/3.d0
            Sol(2) = -0.5d0*(P1 + P2) - a/3.d0 +
     &           I*SQRT(3.d0)/2.d0*(P1-P2)
            Sol(3) = -0.5d0*(P1 + P2) - a/3.d0 -
     &           I*SQRT(3.d0)/2.d0*(P1-P2)
         END IF
      END IF

      RETURN
      END


MODULE module_circle

    IMPLICIT NONE
    REAL, PARAMETER :: PI = 3.1415926

CONTAINS

    REAL FUNCTION circle_area( radius )
        IMPLICIT NONE
        REAL, INTENT(IN) :: radius

        circle_area=PI*(radius**2)
    END FUNCTION

    REAL FUNCTION circle_perimeter( radius )
        IMPLICIT NONE
        REAL, INTENT(IN) :: radius

        circle_perimeter=2*PI*radius
    END FUNCTION

END MODULE module_circle


PROGRAM F007

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER, PARAMETER :: NTH = 10001, N = 1E+6
    INTEGER :: I, J, PRIMES_N
    LOGICAL, DIMENSION(N+1) :: INTEGERS_LIST

    ! USING THE ALGORITHM OF SIEVE OF EROSTHENES
    INTEGERS_LIST = .TRUE.
    I = 2
    DO WHILE ((I*I) <= N)
        IF (INTEGERS_LIST(I)) THEN
            J = I * I
            DO WHILE (J <= N)
                INTEGERS_LIST(J) = .FALSE.
                J = J + I
            END DO
        END IF
        I = I + 1
    END DO

    PRIMES_N = 0
    DO I = 2, N
        IF (INTEGERS_LIST(I)) THEN
            PRIMES_N = PRIMES_N + 1
            IF (PRIMES_N == NTH) THEN
                GOTO 10
            END IF
        END IF
    END DO

    10 CONTINUE

    PRINT ('(I0)'), I

END PROGRAM F007


! The number 3797 has an interesting property.
! Being prime itself, it is possible
! to continuously remove digits from left to right,
! and remain prime at each stage: 3797, 797, 97, and 7.
! Similarly we can work from right to left: 3797, 379, 37, and 3.

! Find the sum of the only eleven primes that are
! both truncatable from left to right and right to left.

! NOTE: 2, 3, 5, and 7 are not considered to be truncatable primes.

! Answer: 748317
! Project Euler: 37

program main

use euler

implicit none

        integer (kind=8), parameter :: PRIME_C = 11;
        integer (kind=8), parameter :: BASE = 10;
        integer (kind=8), parameter :: TWO = 2;
        integer (kind=8) :: c, sum, i;

        c = 0;
        sum = 0;
        i = 3;

        do while(.true.)

                if(truncatable_prime(i)) then

                        call inc(c, ONE);
                        call inc(sum, i);

                        if(c == PRIME_C) then
                                goto 24
                        endif
                endif

                call inc(i, TWO);

        end do

24      CONTINUE

        call printint(sum);

contains

        ! Establishes whether an integer is a truncatable prime. We do this
        ! efficiently by leveraging most of the work into
        ! `possibly_truncatable`, whereby we can check if a number is even
        ! remotely worth running through an expensive check to see if it is
        ! prime. We then check if it is truncatable from both L&R

        pure function truncatable_prime(i)

                integer (kind=8), intent(in) :: i;
                logical :: truncatable_prime

                truncatable_prime = .false.

                if(i < 10 .OR. (.NOT. possibly_truncatable(i))) then
                        return
                endif

                truncatable_prime = (right_trunc(i) .AND. left_trunc(i))

                return

        end function truncatable_prime

        pure function right_trunc(i)

                integer (kind=8), intent(in) :: i;
                integer (kind=8) :: tmp;
                logical :: right_trunc;

                tmp = i;
                right_trunc = .false.

                do while(tmp /= 0)

                        if(.NOT. isprime(tmp)) then
                                return;
                        endif

                        tmp = tmp / 10;

                end do

                right_trunc = .true.

        end function right_trunc

        ! Truncate from the left in a method that is much akin to how we do it
        ! in the `right_trunc` function.

        pure function left_trunc(i)

                integer (kind=8), intent(in) :: i;
                integer (kind=8) :: tmp;
                logical :: left_trunc

                tmp = i;
                left_trunc = .false.

                do while(tmp /= 0)

                        if(.NOT. isprime(tmp)) then
                                return;
                        endif

                        tmp = intrev(intrev(tmp) / 10);

                end do

                left_trunc = .true.

                return

        end function left_trunc

        ! For a number to be prime it must be odd, unless it is two. In this
        ! notion, we may reduce our search space by testing if any of the
        ! digits is even. If so, we know that this number is impossible to
        ! be a truncatable prime. This saves a lot of cycles as we don't need
        ! to expensively check if numbers are prime or not if they aren't even
        ! in the realms of probability of being true.

        pure function possibly_truncatable(i)

                integer (kind=8), intent(in) :: i;
                integer (kind=8) :: tmp, end_d;
                logical :: possibly_truncatable, has_2;

                possibly_truncatable = .false.
                has_2 = .false.
                tmp = i;

                do while(tmp /= 0)

                        ! Check if the end digit is even, but allow one
                        ! occurance of two
                        end_d = mod(tmp, BASE);

                        if(mod(end_d, 2) == 0) then

                                if (end_d == 2) then

                                        if(has_2) then
                                                return;
                                        else
                                                has_2 = .true.
                                        endif
                                else
                                        return;

                                endif
                        endif

                        tmp = tmp / BASE;
                end do

                possibly_truncatable = .true.

        end function possibly_truncatable

end program main


	FUNCTION PR_WCEQ ( tmpf, sknt )
C************************************************************************
C* PR_WCEQ								*
C*									*
C* This function computes WCEQ, the wind chill equivalent temperature,	*
C* from TMPF and SKNT.  The input values will first be converted to	*
C* Celsius and meters per second.  The output will be calculated in	*
C* Fahrenheit.								*
C*									*
C* WCEQ is the temperature with calm winds that produces the same	*
C* cooling effect as the given temperature with the given wind speed.	*
C*									*
C* The following equation is used:					*
C*									*
C*	PR_WCEQ = 33.0 - ( (33.0 - TMPC) * WCI (SPED) / WCI (1.34) )	*
C*									*
C*		where: WCI ( V ) = ( 10.0 * SQRT ( V ) + 10.45 - V )	*
C*									*
C* From: R. Falconer, "Windchill, A Useful Wintertime Weather		*
C*			Variable", Weatherwise, Dec 1968.		*
C*									*
C* REAL PR_WCEQ ( TMPF, SKNT )						*
C*									*
C* Input parameters:							*
C*	TMPF		REAL		Air temperature in deg F	*
C*	SKNT		REAL		Wind speed in knots		*
C*									*
C* Output parameters:							*
C*	PR_WCEQ		REAL		Wind Chill equivalent		*
C*					  temperature in deg F		*
C**									*
C* Log:									*
C* M. Nelson		 7/92	Environmental Information		*
C*				  Summaries C-3, 1975.			*
C* S. Jacobs/EAI	 3/93	Cleaned up				*
C* S. Jacobs/NCEP	 3/96	Recoded and commented equation		*
C* M. Linda/GSC		10/97	Corrected the prologue format		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'ERMISS.FNC'
C*
	WCI ( vel ) = ( 10.0 * SQRT ( vel ) + 10.45 - vel )
C------------------------------------------------------------------------
C*	Convert input variables to Celsius and meters/second.
C
	tmpc = PR_TMFC ( tmpf )
	sped = PR_KNMS ( sknt )
C
C*	Compute the wind chill temp if the inputs are not missing
C*	and the wind speed is greater than 1.34 m/s.
C
	IF  ( ( ERMISS ( tmpc ) ) .or. ( ERMISS ( sped ) ) ) THEN
	    wndchl = RMISSD
	ELSE IF  ( sped .le. 1.34 )  THEN
	    wndchl = tmpc
	ELSE
	    wndchl = 33.0 - ( ( 33.0-tmpc ) * WCI(sped) / WCI(1.34) )
	END IF
C
C*	Convert to Fahrenheit for the user.
C
	PR_WCEQ = PR_TMCF ( wndchl )
C*
	RETURN
	END


    subroutine my_func(x, y)
        implicit none
        complex(kind=kind(0d0)), dimension(3), intent(in) :: x
        complex(kind=kind(0d0)), dimension(2), intent(out) :: y

        integer :: j
        do j = 1, 2
            y(j) = log(x(j) / ((0d0,1d0) + cos(x(j+1))**2))
        end do
    end subroutine my_func

    subroutine my_func_jac(x_value, y_value, dy_dx)
        use adjac
        implicit none
        complex(kind=kind(0d0)), dimension(3), intent(in) :: x_value
        complex(kind=kind(0d0)), dimension(2), intent(out) :: y_value
        complex(kind=kind(0d0)), dimension(2,3), intent(out) :: dy_dx

        type(adjac_complexan), dimension(3) :: x
        type(adjac_complexan), dimension(2) :: y
        integer :: j

        call adjac_reset()
        call adjac_set_independent(x, x_value)

        do j = 1, 2
            y(j) = log(x(j) / ((0d0,1d0) + cos(x(j+1))**2))
        end do

        call adjac_get_value(y, y_value)
        call adjac_get_dense_jacobian(y, dy_dx)
        call adjac_free()
    end subroutine my_func_jac

program simple
  implicit none
  double precision, parameter :: dx = 1e-7

  complex(kind=kind(0d0)), dimension(3) :: x, x2
  complex(kind=kind(0d0)), dimension(2) :: y, y2
  complex(kind=kind(0d0)), dimension(2,3) :: dy_dx

  integer :: i

  do i = 1, 3
     x(i) = i + (0d0,1d0) * i**2
  end do

  ! Evaluate function values
  call my_func(x, y)
  write(*,*) '-- my_func:'
  write(*,*) y

  ! Find jacobian by numerical differentiation
  dy_dx = 0
  do i = 1, 3
     x2 = x
     x2(i) = x(i) + dx
     call my_func(x2, y2)
     dy_dx(:,i) = (y2 - y) / dx
  end do

  write(*,*) '-- Jacobian via numerical differentiation:'
  do i = 1, 2
     write(*,*) cmplx(dy_dx(i,:))
  end do

  ! Get the same results via adjac
  dy_dx = 0
  call my_func_jac(x, y, dy_dx)
  write(*,*) '-- my_func_jac value:'
  write(*,*) y
  write(*,*) '-- my_func_jac Jacobian:'
  do i = 1, 2
     write(*,*) cmplx(dy_dx(i,:))
  end do

end program simple


 FUNCTION IDAY(YYYY, MM, DD) RESULT(IVAL)
!====IDAY IS A COMPANION TO CALEND; GIVEN A CALENDAR DATE, YYYY, MM,
!           DD, IDAY IS RETURNED AS THE DAY OF THE YEAR.
!           EXAMPLE: IDAY(1984, 4, 22) = 113

 INTEGER, INTENT(IN) :: YYYY, MM, DD
 INTEGER             :: IVAL

 IVAL = 3055*(MM+2)/100 - (MM+10)/13*2 -91 +  &
       (1-(MODULO(YYYY, 4)+3)/4              &
        + (MODULO(YYYY, 100) + 99)/100 -        &
       (MODULO(YYYY, 400)+399)/400)*(MM+10)/13 + DD

 RETURN
 END FUNCTION IDAY

FUNCTION JD_OUT(YYYY, MM, DD) RESULT(IVAL)
  INTEGER, INTENT(IN)  :: YYYY
  INTEGER, INTENT(IN)  :: MM
  INTEGER, INTENT(IN)  :: DD
  INTEGER*8            :: IVAL
!              DATE ROUTINE JD(YYYY, MM, DD) CONVERTS CALENDER DATE TO
!              JULIAN DATE.  SEE CACM 1968 11(10):657, LETTER TO THE
!              EDITOR BY HENRY F. FLIEGEL AND THOMAS C. VAN FLANDERN.
!    EXAMPLE JD(1970, 1, 1) = 2440588
  IVAL = DD - 32075 + 1461*(YYYY+4800+(MM-14)/12)/4 +  &
        367*(MM-2-((MM-14)/12)*12)/12 - 3*((YYYY+4900+(MM-14)/12)/100)/4
  RETURN
 END FUNCTION JD_OUT

 SUBROUTINE CDATE(JD,YYYY,MM,DD)
!====GIVEN A JULIAN DAY NUMBER, NNNNNNNN, YYYY,MM,DD ARE RETURNED AS THE
!         CALENDAR DATE. JD = NNNNNNNN IS THE JULIAN DATE FROM AN EPOCH
!         IN THE VERY DISTANT PAST.  SEE CACM 1968 11(10):657,
!         LETTER TO THE EDITOR BY FLIEGEL AND VAN FLANDERN.
!    EXAMPLE CALL CDATE(2440588, YYYY, MM, DD) RETURNS 1970 1 1 .

 INTEGER,INTENT(IN)  ::  JD
 INTEGER,INTENT(OUT) ::  YYYY,MM,DD
 INTEGER L

 L = JD + 68569
 N = 4*L/146097
 L = L - (146097*N + 3)/4
 YYYY = 4000*(L+1)/1461001
 L = L - 1461*YYYY/4 + 31
 MM = 80*L/2447
 DD = L - 2447*MM/80
 L = MM/11
 MM = MM + 2 - 12*L
 YYYY = 100*(N-49) + YYYY + L
 RETURN
 END SUBROUTINE CDATE

      FUNCTION REF_ATT (R_TIME, R_DATE)
!
!=======================================================================
!                                                                      !
!  This function encodes the relative time attribute that gives the    !
!  elapsed interval since a specified reference time.  The "units"     !
!  attribute takes the form "time-unit since reference-time".          !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     r_time     Time-reference (real; %Y%m%d.%f, for example,         !
!                  20020115.5 for 15 Jan 2002, 12:0:0).                !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     ref_att    Time-reference for "units" attribute (string).        !
!     r_date     Calendar date vector (real):                          !
!                  r_date(1) => reference date (yyyymmdd.f).           !
!                  r_date(2) => year.                                  !
!                  r_date(3) => year day.                              !
!                  r_date(4) => month.                                 !
!                  r_date(5) => day.                                   !
!                  r_date(6) => hour.                                  !
!                  r_date(7) => minute.                                !
!                  r_date(8) => second.                                !
!                                                                      !
!=======================================================================
!
!

!
!  Imported variable declarations.
!
      USE GLOBAL
      REAL(WP), INTENT(IN) :: R_TIME
      REAL(WP), DIMENSION(8), INTENT(OUT) :: R_DATE
      CHARACTER (LEN=19) :: REF_ATT
!
!  Local variable declarations.
!
      INTEGER(WP) :: IDAY, IHOUR, ISEC, IYEAR, LEAP, MINUTE, MONTH
      INTEGER(WP), DIMENSION(13) :: IYD =                                   &
     &         (/ 1,32,60,91,121,152,182,213,244,274,305,335,366 /)
      INTEGER(WP), DIMENSION(13) :: IYDL =                                  &
     &         (/ 1,32,61,92,122,153,183,214,245,275,306,336,367 /)
      REAL(WP) :: DAY, SEC, YDAY
      CHARACTER (LEN=19) :: TEXT
!
!-----------------------------------------------------------------------
!  Decode reference time.
!-----------------------------------------------------------------------
!
      IYEAR=MAX(1,INT(R_TIME*0.0001))
      MONTH=MIN(12,MAX(1,INT((R_TIME-REAL(IYEAR*10000))*0.01)))
      DAY=R_TIME-AINT(R_TIME*0.01)*100.0
      IDAY=INT(DAY)
      SEC=(DAY-AINT(DAY))*86400.0
      IHOUR=INT(SEC/3600.0)
      MINUTE=INT(MOD(SEC,3600.0)/60.0)
      ISEC=INT(MOD(SEC,60.0))
!
!-----------------------------------------------------------------------
!  Get year day.
!-----------------------------------------------------------------------
!
      LEAP=MOD(IYEAR,4)
      IF (LEAP.EQ.0) THEN
        YDAY=REAL(IYDL(MONTH))+REAL(IDAY)-1.0
      ELSE
        YDAY=REAL(IYD(MONTH))+REAL(IDAY)-1.0
      END IF
!
!-----------------------------------------------------------------------
!  Build output date vector.
!-----------------------------------------------------------------------
!
      R_DATE(1)=R_TIME
      R_DATE(2)=REAL(IYEAR)
      R_DATE(3)=MAX(1.0,YDAY)
      R_DATE(4)=REAL(MONTH)
      R_DATE(5)=MAX(1.0,REAL(IDAY))
      R_DATE(6)=REAL(IHOUR)
      R_DATE(7)=REAL(MINUTE)
      R_DATE(8)=REAL(ISEC)
!
!-----------------------------------------------------------------------
!  Build reference-time string.
!-----------------------------------------------------------------------
!
      WRITE (TEXT,10) IYEAR, MONTH, IDAY, IHOUR, MINUTE, ISEC
 10   FORMAT (I4,'-',I2.2,'-',I2.2,1X,I2.2,':',I2.2,':',I2.2)
      REF_ATT=TEXT
      RETURN
      END FUNCTION REF_ATT

   SUBROUTINE  CONVERSION(NUMBER, YEAR, MONTH, DAY)
   IMPLICIT  NONE

   INTEGER, INTENT(IN)  :: NUMBER
   INTEGER, INTENT(OUT) :: YEAR, MONTH, DAY

   YEAR  = NUMBER / 10000
   MONTH = MOD(NUMBER, 10000) / 100
   DAY   = MOD(NUMBER, 100)
   END SUBROUTINE  CONVERSION


! Ricker wavelet
subroutine ricker(nt,f0,dt,source)
    implicit none
    integer                      :: nt, it
    real (kind=8)                :: f0, pt, a_ricker, dt, t0,t
    real (kind=8),dimension(nt)  :: source, temp

    source = 0
    temp   = 0
    pt = 1 / f0
    t0=pt/dt
    a_ricker=4./pt

    do it=1,nt+1
        t=(it-t0)*dt
        temp(it) = -2.*a_ricker*t*exp(-(a_ricker*t)**2)
    enddo

    do it=1,nt
        source(it) = temp(it+1) - temp(it)
    end do

    source = -source

END subroutine ricker


subroutine eigenvalueprob(NDIM,A,W,WORK,workmax,A_OLD)
implicit none

!Global variables

INTEGER, INTENT(IN)      :: NDIM, workmax
REAL(kind=4), intent(out) :: WORK(workmax), W(NDIM)
REAL(kind=4), intent(inout) ::A(NDIM,NDIM),A_OLD(NDIM,NDIM)

!Local Variables
integer      :: LDA,LWORK, INFO, J, I
real(kind=4)     ::  eps
real(kind=4)     ::  slamch
CHARACTER    :: JOBZ,UPLO
REAL             ZERO
PARAMETER        ( ZERO = 0.0 )
real(kind=4)     :: cpu_sekunden, st0, ste

    external slamch
    external ssyev

    eps = slamch('e')
    print*,' relative machine precision epsilon          ',&
            ' eps      = ',eps

    JOBZ = 'V'
    UPLO = 'U'

    LDA = NDIM

    LWORK = workmax

    call cpu_time(st0)
!--------------------------------!

    CALL ssyev(JOBZ,UPLO,NDIM,A,LDA,W,WORK, LWORK, INFO)
!--------------------------------!

    print*,' LAPACK INFO = ',info

    IF( INFO.GT.0 ) THEN
        WRITE(*,*)'The calculation was unsuccessfull.'
        STOP
     END IF

    print*,' '

!-------------------------!
    PRINT*,' Eigenvalues :'
    PRINT*,' '
    DO J = 1, NDIM
          WRITE(*,*) W( J )
    END DO
    WRITE(*,*)

!-------------------------!
    WRITE(*,*) 'Eigenvectors:'
    WRITE(*,*) 'Columnwise saved'
   do i = 1, ndim
      write(*,*)(A(i,j),j=1,ndim)
   end do

    call cpu_time(ste)
    cpu_sekunden = (ste - st0)
    print*, ''
    print*,' CPU Time: ',cpu_sekunden

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

end subroutine eigenvalueprob


FUNCTION random_gamma(s, b, first) RESULT(fn_val)

! Adapted from Fortran 77 code from the book:
!     Dagpunar, J. 'Principles of random variate generation'
!     Clarendon Press, Oxford, 1988.   ISBN 0-19-852202-9

!     N.B. This version is in `double precision' and includes scaling

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

!     S = SHAPE PARAMETER OF DISTRIBUTION (0 < REAL).
!     B = Scale parameter

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

REAL (dp), INTENT(IN)  :: s, b
LOGICAL, INTENT(IN)    :: first
REAL (dp)              :: fn_val

! Local parameters
REAL (dp), PARAMETER  :: one = 1.0_dp, zero = 0.0_dp

IF (s <= zero) THEN
  WRITE(*, *) 'SHAPE PARAMETER VALUE MUST BE POSITIVE'
  STOP
END IF

IF (s >= one) THEN
  fn_val = random_gamma1(s, first)
ELSE IF (s < one) THEN
  fn_val = random_gamma2(s, first)
END IF

! Now scale the random variable
fn_val = b * fn_val
RETURN

CONTAINS

FUNCTION random_gamma1(s, first) RESULT(fn_val)

! Adapted from Fortran 77 code from the book:
!     Dagpunar, J. 'Principles of random variate generation'
!     Clarendon Press, Oxford, 1988.   ISBN 0-19-852202-9

! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY) FROM
! A GAMMA DISTRIBUTION WITH DENSITY PROPORTIONAL TO GAMMA**(S-1)*EXP(-GAMMA),
! BASED UPON BEST'S T DISTRIBUTION METHOD

!     S = SHAPE PARAMETER OF DISTRIBUTION
!          (1.0 < REAL)

REAL (dp), INTENT(IN)  :: s
LOGICAL, INTENT(IN)    :: first
REAL (dp)              :: fn_val

!     Local variables
REAL (dp)             :: d, r, g, f, x
REAL (dp), SAVE       :: b, h
REAL (dp), PARAMETER  :: sixty4 = 64.0_dp, three = 3.0_dp, pt75 = 0.75_dp,  &
                         two = 2.0_dp, half = 0.5_dp

IF (s <= one) THEN
  WRITE(*, *) 'IMPERMISSIBLE SHAPE PARAMETER VALUE'
  STOP
END IF

IF (first) THEN                        ! Initialization, if necessary
  b = s - one
  h = SQRT(three*s - pt75)
END IF

DO
  CALL RANDOM_NUMBER(r)
  g = r - r*r
  IF (g <= zero) CYCLE
  f = (r - half)*h/SQRT(g)
  x = b + f
  IF (x <= zero) CYCLE
  CALL RANDOM_NUMBER(r)
  d = sixty4*g*(r*g)**2
  IF (d <= zero) EXIT
  IF (d*x < x - two*f*f) EXIT
  IF (LOG(d) < two*(b*LOG(x/b) - f)) EXIT
END DO
fn_val = x

RETURN
END FUNCTION random_gamma1

FUNCTION random_gamma2(s, first) RESULT(fn_val)

! Adapted from Fortran 77 code from the book:
!     Dagpunar, J. 'Principles of random variate generation'
!     Clarendon Press, Oxford, 1988.   ISBN 0-19-852202-9

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

!    S = SHAPE PARAMETER OF DISTRIBUTION
!          (REAL < 1.0)

REAL (dp), INTENT(IN)  :: s
LOGICAL, INTENT(IN)    :: first
REAL (dp)              :: fn_val

!     Local variables
REAL (dp)             :: r, x, w
REAL (dp), SAVE       :: a, p, c, uf, vr, d
REAL (dp), PARAMETER  :: vsmall = EPSILON(one)

IF (s <= zero .OR. s >= one) THEN
  WRITE(*, *) 'SHAPE PARAMETER VALUE OUTSIDE PERMITTED RANGE'
  STOP
END IF

IF (first) THEN                        ! Initialization, if necessary
  a = one - s
  p = a/(a + s*EXP(-a))
  IF (s < vsmall) THEN
    WRITE(*, *) 'SHAPE PARAMETER VALUE TOO SMALL'
    STOP
  END IF
  c = one/s
  uf = p*(vsmall/a)**s
  vr = one - vsmall
  d = a*LOG(a)
END IF

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

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

fn_val = x
RETURN

END FUNCTION random_gamma2

END FUNCTION random_gamma

PROGRAM demo_gamma
! Demo program to generate a small smaple of random gamma's

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

REAL (dp)  :: shape, scale, rg(100), avge, mean
LOGICAL    :: first
INTEGER    :: i, order(100)

INTERFACE
  FUNCTION random_gamma(s, b, first) RESULT(fn_val)
    IMPLICIT NONE
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)
    REAL (dp), INTENT(IN)  :: s, b
    LOGICAL, INTENT(IN)    :: first
    REAL (dp)              :: fn_val
  END FUNCTION random_gamma

  RECURSIVE SUBROUTINE quick_sort(list, order)
    IMPLICIT NONE
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)
    REAL (dp), DIMENSION (:), INTENT(IN OUT)  :: list
    INTEGER, DIMENSION (:), INTENT(OUT)      :: order
  END SUBROUTINE quick_sort
END INTERFACE

WRITE(*, '(a)', ADVANCE='NO') ' Enter the shape & scale parameter values: '
READ(*, *) shape, scale

first = .TRUE.
DO i = 1, 100
  rg(i) = random_gamma(shape, scale, first)
  first = .FALSE.
END DO

CALL quick_sort(rg, order)
WRITE(*, '(" ", 10f7.3)') rg

mean = shape * scale
avge = SUM( rg ) / 100._dp
WRITE(*, '(a, g12.5, a, g12.5)')  &
         ' Population mean = ', mean, '  Sample mean = ', avge

STOP
END PROGRAM demo_gamma

RECURSIVE SUBROUTINE quick_sort(list, order)

! Quick sort routine from:
! Brainerd, W.S., Goldberg, C.H. & Adams, J.C. (1990) "Programmer's Guide to
! Fortran 90", McGraw-Hill  ISBN 0-07-000248-7, pages 149-150.
! Modified by Alan Miller to include an associated integer array which gives
! the positions of the elements in the original order.

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

REAL (dp), DIMENSION (:), INTENT(IN OUT)  :: list
INTEGER, DIMENSION (:), INTENT(OUT)       :: order

! Local variable
INTEGER :: i

DO i = 1, SIZE(list)
  order(i) = i
END DO

CALL quick_sort_1(1, SIZE(list))
RETURN

CONTAINS

RECURSIVE SUBROUTINE quick_sort_1(left_end, right_end)

INTEGER, INTENT(IN) :: left_end, right_end

!     Local variables
INTEGER             :: i, j, itemp
REAL (dp)           :: reference, temp
INTEGER, PARAMETER  :: max_simple_sort_size = 6

IF (right_end < left_end + max_simple_sort_size) THEN
  ! Use interchange sort for small lists
  CALL interchange_sort(left_end, right_end)

ELSE
  ! Use partition ("quick") sort
  reference = list((left_end + right_end)/2)
  i = left_end - 1
  j = right_end + 1

  DO
    ! Scan list from left end until element >= reference is found
    DO
      i = i + 1
      IF (list(i) >= reference) EXIT
    END DO
    ! Scan list from right end until element <= reference is found
    DO
      j = j - 1
      IF (list(j) <= reference) EXIT
    END DO

    IF (i < j) THEN
      ! Swap two out-of-order elements
      temp = list(i)
      list(i) = list(j)
      list(j) = temp
      itemp = order(i)
      order(i) = order(j)
      order(j) = itemp
    ELSE IF (i == j) THEN
      i = i + 1
      EXIT
    ELSE
      EXIT
    END IF
  END DO

  IF (left_end < j) CALL quick_sort_1(left_end, j)
  IF (i < right_end) CALL quick_sort_1(i, right_end)
END IF

RETURN
END SUBROUTINE quick_sort_1

SUBROUTINE interchange_sort(left_end, right_end)

INTEGER, INTENT(IN) :: left_end, right_end

!     Local variables
INTEGER             :: i, j, itemp
REAL (dp)           :: temp

DO i = left_end, right_end - 1
  DO j = i+1, right_end
    IF (list(i) > list(j)) THEN
      temp = list(i)
      list(i) = list(j)
      list(j) = temp
      itemp = order(i)
      order(i) = order(j)
      order(j) = itemp
    END IF
  END DO
END DO

RETURN
END SUBROUTINE interchange_sort

END SUBROUTINE quick_sort


!=====================================================================!
! Module containing test problems for Newton's method
!=====================================================================!

module test_problems

  implicit none

contains

  ! f = 2x^2 -5
  pure function f1(x)
    real(8), intent(in) :: x(:)
    real(8) :: f1(size(x))
    f1 = 2.0d0*x*x - 5.0d0
  end function f1

  ! dfdx = 4x
  pure function dfdx1(x)
    real(8), intent(in) :: x(:)
    real(8) :: dfdx1(size(x),size(x))
    dfdx1(1,1) = 4.0d0*x(1)
  end function dfdx1

  ! f = sin(x) + x
  pure function f2(x)
    real(8), intent(in) :: x(:)
    real(8) :: f2(size(x))
    f2 = sin(x) + x
  end function f2

  ! dfdx = cos(x) + 1
  pure function dfdx2(x)
    real(8), intent(in) :: x(:)
    real(8) :: dfdx2(size(x),size(x))
    dfdx2(1,1) = cos(x(1)) + 1.0d0
  end function dfdx2

  ! f = cos(x)
  pure function f3(x)
    real(8), intent(in) ::  x(:)
    real(8) :: f3(size(x))
    f3 = cos(x)
  end function f3

  ! dfdx = sin(x)
  pure function dfdx3(x)
    real(8), intent(in) :: x(:)
    real(8) :: dfdx3(size(x),size(x))
    dfdx3(1,1) = -sin(x(1))
  end function dfdx3

  ! Chandrasekhar H equations
  function chandra_res(x)

    real(8), intent(in) :: x(:)
    real(8)  :: chandra_res(size(x))
    integer, parameter  :: N = 200
    real(8), parameter  :: c = 0.9d0

    if ( n .ne. 200) stop "variable-mismatch"

    assemble: block

      real(8) :: mui, muj, alpha, beta
      integer :: i, j

      do i = 1, N

         mui = (dble(i) - 0.5d0)/dble(N)

         ! Find the term within integral
         alpha = 0.0d0
         do j = 1, N
            muj = (dble(j) - 0.5d0)/dble(N)
            alpha = mui*x(j)/(mui+muj)
         end do

         ! Evaluate the inverse term
         beta = 1.0d0 - c*alpha/(2.0d0*dble(N))

         ! Assmble residual
         chandra_res(i) = x(i) - 1.0d0/beta

      end do

    end block assemble

  end function chandra_res

  !===================================================================!
  ! Finite difference approximation for jacobian
  !===================================================================!

  function chandra_jac(x)

    use nonlinear_algebra, only : diffjac

    real(8), intent(in) :: x(:)
    real(8) :: chandra_jac(size(x),size(x))
    integer, parameter :: N = 200

    call diffjac(x, chandra_res, chandra_jac)

  end function chandra_jac

end module test_problems

!=====================================================================!
! Main program to solve the test problems using different methods
!=====================================================================!

program test_nonlinear

  use test_problems, only : f1, f2, f3, dfdx1, dfdx2, dfdx3, &
       & chandra_res, chandra_jac

  use nonlinear_algebra, only : newton, secant, chord, fixed_point, &
       & shamanskii

  implicit none

  real(8), parameter :: tau_r = 1.0d-6
  real(8), parameter :: tau_a = 1.0d-6
  integer, parameter :: maxit = 100

  integer :: iter, flag
  real(8) :: tol

  ! Test nonlinear solvers on chandrasekhar method
  test_chandra: block

    integer, parameter :: npts = 200
    real(8) :: x(npts,4)

    print *, "Chandrasekhar Equation using Newton method"

    x(:,1) = 2.0d0
    call newton(chandra_res, chandra_jac, tau_r, tau_a, maxit, x(:,1))
    !print *, x(:,1)

    print *, "Chandrasekhar Equation using chord method"
    x(:,2) = 1.0d0
    call chord(chandra_res, chandra_jac, tau_r, tau_a, maxit, x(:,2))
    !print *, x(:,2)

    print *, "Chandrasekhar Equation using fixed point method"
    x(:,3) = 1.0d0
    call fixed_point(chandra_res, tau_r, tau_a, maxit, x(:,3))
    !print *, x(:,3)

    print *, "Chandrasekhar Equation using shamanskii method"
    x(:,4) = 1.0d0
    call shamanskii(chandra_res, chandra_jac, 2, tau_r, tau_a, maxit, x(:,4))
    !print *, x(:,4)

  end block test_chandra

  test_f1 : block

    integer, parameter :: npts = 1
    real(8) :: x(npts), x0(npts)

    print *, "function 1 using newton method"
    x = 10.0d0
    call newton(f1, dfdx1, tau_r, tau_a, maxit, x)
    print *, x

    print *, "function 1 using secant method"
    x = 10.0d0
    x0 = 0.99d0*x
    call secant(f1, tau_r, tau_a, maxit, x0, x)
    print *, x

    print *, "function 1 using chord method"
    x = 10.0d0
    call chord(f1, dfdx1, tau_r, tau_a, maxit, x)
    print *, x

  end block test_f1

  test_f2: block

    integer, parameter :: npts = 1
    real(8) :: x(npts), x0(npts)

    print *, "function 2 using newton method"
    x = 0.5d0
    call newton(f2, dfdx2, tau_r, tau_a, maxit, x)
    print *, x

    print *, "function 2 using secant method"
    x = 0.5d0
    x0 = 0.99d0*x
    call secant(f2, tau_r, tau_a, maxit, x0, x)
    print *, x

    print *, "function 2 using chord method"
    x = 0.5d0
    call chord(f2, dfdx2, tau_r, tau_a, maxit, x)
    print *, x

  end block test_f2

  test_f3: block

    integer, parameter :: npts = 1
    real(8) :: x(npts), x0(npts)

    print *, "function 3 using newton method"
    x = 3.0d0
    call newton(f3, dfdx3, tau_r, tau_a, maxit, x)
    print *, x

    print *, "function 3 using secant method"
    x = 3.0d0
    x0 = 0.99d0*x
    call secant(f3, tau_r, tau_a, maxit, x0, x)
    print *, x

    print *, "function 3 using chord method"
    x = 3.0d0
    call chord(f3, dfdx3, tau_r, tau_a, maxit, x)
    print *, x

  end block test_f3

end program test_nonlinear


program insertion
implicit none

!-----------------------------------------------------------------
! This programme sorts a series of values in increasing order,
! using insertion sort, implemented with one working array
!
! It works like this:
! unsorted: A = [5, 3, 4, 1, 2, 6]
! sorting:
! pass 1: A = [3, 5, 4, 1, 2, 6]
! pass 2: A = [3, 4, 5, 1, 2, 6]
! pass 3: A = [1, 3, 4, 5, 2, 6]
! pass 4: A = [1, 2, 3, 4, 5, 6]
! pass 5: B = [1, 2, 3, 4, 5, 6]
!------------------------------------------------------

real(kind=8), allocatable, dimension(:) :: A
real :: temp
integer :: i, j, k, n

!------------------------------------------------------------
! Make some random array:
!------------------------------------------------------------

write(*,*) 'size od array?'
read(*,*) n
allocate (A(n))

call random_seed()
do i = 1, n
   call random_number(A(i))
   A(i) = (A(i) * 100.0)
   A(i) = real(nint(A(i)*1000)) / 1000.0 !rounding off to 3 decimal places
end do

!------------------------------------------------------------
! Prepare output file:
!------------------------------------------------------------

open(unit=1, file='insert', status='replace', action='write')
write(1,*) 'here you can see the details of how the loops and conditionals'
write(1,*) 'really work'

write(1,*)
write(1,*) '(using one array)'
write(1,*)
write(1,'(A3,10F7.3)') ' A ', A
write(*,'(A3,10F7.3)') ' A ', A
write(1,*)

!------------------------------------------------------------
! The actual sorting:
!------------------------------------------------------------

do i = 2, n
   write (1,*) 'i', i
   do j = 1, i-1
      write(1,*) '   j', j
      if (A(j) .ge. A(i)) then
         write(1,*) 'found it'
         temp = A(i)
         do k = i-1, j, -1 !from the last value different from 0, to
!                                   the first one greater than i
            A(k+1) = A(k) !move every element by one
            write(1,*) '      k', k
         end do
         A(j) = temp
         exit
      end if
   end do
   write(1,'(I4,10F7.3)') i, A
   write(1,*)
   write(*,'(I4,10F7.3)') i, A
end do

end program insertion


! Created by EverLookNeverSee@GitHub on 4/15/20.
! This program calculates the roots of a quadratic equaion.

program roots
    implicit none
    ! defining variables
    real :: a, b, c, x_1, x_2, delta, sr_delta
    ! getting user input
    print *, "Enter the values of a, b, c:"
    read *, a, b, c
    ! calculating delta
    delta = (b ** 2) - (4.0 * a * c)
     if (delta > 0.0) then
        sr_delta = sqrt(delta)
        x_1 = (-b + sr_delta) / (2.0 * a)
        x_2 = (-b - sr_delta) / (2.0 * a)
        print *, "roots are:", x_1, x_2
    elseif (delta == 0.0) then
        x_1 = -b / (2.0 * a)
        x_2 = x_1
        print *, "roots are equal:", x_1, x_2
    else    ! value of delta is less than 0.0
        print *, "This quadratic equation has no real root."
    end if
end program roots


SUBROUTINE interp_lin (x, y, x_int, y_int)

! ----------------------------------------------------------------------
! Subroutine:  interp_lin.f90
! ----------------------------------------------------------------------
! Purpose:
!  Linear interpolation based on two data points
! ----------------------------------------------------------------------
! Input arguments:
! - x:			Array with two values of the x variable
! - y:			Array with two values of the y variable given as a
!               function of x. y = f(x)
! - x_int:		Value of x variable that the interpolation of y is required
!
! Output arguments:
! - y_int:		Interpolated value of y variable at the value x_int
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia               March 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN) :: x(2), y(2), x_int
! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: y_int
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
      y_int = y(1) + ( x_int - x(1) ) * ( (y(2) - y(1)) / (x(2) - x(1)) )
! ----------------------------------------------------------------------

END


MODULE MathConstants

   SAVE
   REAL    (KIND=8), PARAMETER :: pi = 3.1415926535898D0, RadDeg = 180.0D0 / pi, DegRad = pi / 180.0D0
   COMPLEX (KIND=8), PARAMETER :: i  = ( 0.0D0, 1.0D0 )

END MODULE MathConstants


!> \file p80.f90
!! \BRIEF
!> Module with p80 function - compute pressure from depth
MODULE mp80
CONTAINS
!>     Function to compute pressure from depth using Saunder's (1981) formula with eos80.
FUNCTION p80(dpth,xlat)

  !     Compute Pressure from depth using Saunder's (1981) formula with eos80.

  !     Reference:
  !     Saunders, Peter M. (1981) Practical conversion of pressure
  !     to depth, J. Phys. Ooceanogr., 11, 573-574, (1981)

  !     Coded by:
  !     R. Millard
  !     March 9, 1983
  !     check value: p80=7500.004 dbars at lat=30 deg., depth=7321.45 meters

  !     Modified (slight format changes + added ref. details):
  !     J. Orr, 16 April 2009

  USE msingledouble
  IMPLICIT NONE

! Input variables:
  !> depth [m]
  REAL(kind=rx), INTENT(in) :: dpth
  !> latitude [degrees]
  REAL(kind=rx), INTENT(in) :: xlat

! Output variable:
  !> pressure [db]
  REAL(kind=rx) :: p80

! Local variables:
  REAL(kind=rx) :: pi
  REAL(kind=rx) :: plat, d, c1

  pi=3.141592654

  plat = ABS(xlat*pi/180.)
  d  = SIN(plat)
  c1 = 5.92e-3+d**2 * 5.25e-3

  p80 = ((1-c1)-SQRT(((1-c1)**2)-(8.84e-6*dpth))) / 4.42e-6

  RETURN
END FUNCTION p80
END MODULE mp80


real, dimension(n,m) :: a = reshape( [ (i, i=1, n*m) ], [ n, m ] )
real, dimension(m,k) :: b = reshape( [ (i, i=1, m*k) ], [ m, k ] )
real, dimension(size(a,1), size(b,2)) :: c    ! C is an array whose first dimension (row) size
                                              ! is the same as A's first dimension size, and
                                              ! whose second dimension (column) size is the same
                                              ! as B's second dimension size.

c = matmul( a, b )

print *, 'A'
do i = 1, n
    print *, a(i,:)
end do

print *,
print *, 'B'
do i = 1, m
    print *, b(i,:)
end do

print *,
print *, 'C = AB'
do i = 1, n
    print *, c(i,:)
end do