!  SFM  04/06/2013  Code module added for WOlson
!
! -------------------------- fband.f90 -------------------------------
!       Translated from C language by J.-P. Moreau, March, 1999.
!   Reference: Numerical Algotithms with C, Springer, 1996 [BIBLI 11]

!  Subroutine band(mode,n,ld,ud,pmat,b,perm,signd,code)
Subroutine band(mode,n,ww,bb,code)
  implicit none
  integer maxlyr, ld, n, mode
  INTEGER code,ud,signd,perm(0:n-1)
  REAL*8 pmat(0:n-1,0:n-1),b(0:n-1)
  PARAMETER    ( MAXLYR = 80 )
  real *8 BB(2*MAXLYR), WW(2*MAXLYR,2*MAXLYR) !WSO 04/07/2013
  integer:: i, k
  INTEGER rc
  ld=2
  ud=2
  pmat=0
  do i=0,n-1
     b(i)=bb(i+1)
     pmat(i,2)=ww(i+1,i+1)
     do k=-2,2
        if(i+1+k>0 .and. i+1+k<=n) then
           pmat(i,2+k)=ww(i+1,i+1+k)
        endif
     enddo
  enddo

!======================================================================
!*                                                                    *
!*  The subroutine band solves a linear banded system:  pmat * x = b  *
!*  Here pmat is a nonsingular n x n matrix in condensed form, i.e.   *
!*  represented in an ld+ud+1 x n matrix for its ld lower and ud upper*
!*  co-diagonals. b denotes the right hand side of the system, and x  *
!*  is the solution.                                                  *
!*                                                                    *
!*  band uses the Gauss algorithm with column pivot search.           *
!*  The result of pivoting are min( ud, ld) additional columns,       *
!*  so that pmat needs all in all a n x (ld+1+ud+min(ld,ud)) matrix.  *
!*                                                                    *
!* ------------------------------------------------------------------ *
!*                                                                    *
!*   Applications:                                                    *
!*   -------------                                                    *
!*      Solve linear systems with nonsingular banded system matrices. *
!*      Particularly useful for large sparse and banded matrices with *
!*      n >> ld+1+ud.                                                 *
!*                                                                    *
!* ------------------------------------------------------------------ *
!*                                                                    *
!*   Control parameter:                                               *
!*   ------------------                                               *
!*      mode     integer mode : calling modus for band.               *
!*       = 0     factor matrix and solve linear system                *
!*       = 1     factor only, store factors in pmat                   *
!*       = 2     solve linear system only; for this call, the factors *
!*               must already be available in pmat, such as when      *
!*               many systems are solved for differing right hand     *
!*               sides and the same system matrix.                    *
!*                                                                    *
!*   Input parameters:                                                *
!*   -----------------                                                *
!*      n        integer n  ( n > 2 )                                 *
!*               Dimension of pmat, size of b                         *
!*      ld       integer ld; ( ld >= 0 )                              *
!*               number of lower co-diagonals                         *
!*      ud       integer ud; ( ud >= 0 )                              *
!*               number of upper co-diagonals                         *
!*      pmat     REAL*8 pmat(0:n-1,0:n-1)                             *
!*               mode = 0, 1:                                         *
!*               Matrix of the system in condensed form.              *
!*               Each row has length at least ld + 1 + ud + min(ld,ud)*
!*               where the columns 0, .., ld-1 denote the lower       *
!*               co-diagonals, column ld stores the diagonal and the  *
!*               columns ld+1, .., ld+ud contain the upper            *
!*               co-diagonals.                                        *
!*               If A is the original uncondensed band matrix, then : *
!*               A[i][k] = pmat[i][ld+k-i],                           *
!*                           for k,i inside the band                  *
!*               mode = 2                                             *
!*               LU factors in condensed form.                        *
!*      b        REAL*8 b(0:n-1)           ( for mode = 0, 2 )        *
!*               Right hand side                                      *
!*      perm     integer perm(0:n-1)       ( for mode = 2 )           *
!*               row permutation vector                               *
!*      signd    integer signd             ( for mode= 2 )            *
!*               sign of perm. The determinant of A can be computed   *
!*               as the product of the diagonal entries times signd.  *
!*                                                                    *
!*   Output parameters:                                               *
!*   ------------------                                               *
!*      pmat     REAL*8 pmat(0:n-1,0:n-1)  ( for mode= 0, 1 )         *
!*               LU factorization in condensed form                   *
!*      perm     integer perm[n]           ( for mode = 0, 1 )        *
!*               row permutation vector                               *
!*      b        REAL*8 b(0:n-1)           ( for mode = 0, 2 )        *
!*               solution vector for the system                       *
!*      signd    integer signd;            ( for mode = 0, 1 )        *
!*               sign of perm              ( value:  1 or -1 )        *
!*                                                                    *
!*   Return value code                                                *
!*   -----------------                                                *
!*      = 0      all ok                                               *
!*      = 1      n < 3 or other incorrect input parameter             *
!*      = 2      not used here                                        *
!*      = 3      Matrix is numerically singular                       *
!*      = 4      wrong calling modus                                  *
!*                                                                    *
!* ------------------------------------------------------------------ *
!*                                                                    *
!*   Subroutines used:                                                *
!*   ----------------                                                 *
!*      banddec : Factor matrix                                       *
!*      bandsol : solve linear system                                 *
!*                                                                    *
!======================================================================

  if (n < 1.or.ld < 0.or.ud < 0) then
    code=1
    return
  end if

  SELECT CASE (mode)
    CASE (0)  ! factor and solve system ...............................
      call banddec (n, ld, ud, pmat, perm, signd,rc)
      if (rc.eq.0) then
        call bandsol (n, ld, ud, pmat, b, perm, code)
      else
        code=rc
      end if
    CASE (1)   ! factor only ...........................................
       call banddec (n, ld, ud, pmat, perm, signd, code)
    CASE (2)   ! solve only ............................................
       call bandsol (n, ld, ud, pmat, b, perm, code)
    CASE DEFAULT
       code = 4
  END SELECT

  do i=0,n-1
     bb(i+1)=b(i)
  enddo
  return
  end

  Subroutine banddec(n,ld,ud,pmat,perm,signd,code)
  PARAMETER(MACH_EPS=1.D-15)
  INTEGER code,ud,signd,perm(0:n-1)
  REAL*8 pmat(0:n-1,0:n-1)
!======================================================================
!*                                                                    *
!*  The subroutine banddec factors a condensed banded matrix pmat.    *
!*  banddec uses the Gauss algorithm with column pivot search.        *
!*                                                                    *
!* ------------------------------------------------------------------ *
!*                                                                    *
!*   Input parameters:                                                *
!*   ----------------                                                 *
!*      n        integer n   ( n > 2 )                                *
!*               Dimension of pmat, size of b                         *
!*      ld       integer ld  ( ld >= 0 )                              *
!*               number of lower co-diagonals                         *
!*      ud       integer ud  ( ud >= 0 )                              *
!*               number of upper co-diagonals                         *
!*      pmat     REAL*8 pmat(0:n-1,0:n-1)                             *
!*               Matrix of the system in comndensed form.             *
!*               Each row has length at least ld + 1 + ud + min(ld,ud)*
!*               where the columns 0, .., ld-1 denote the lower       *
!*               co-diagonals, column ld stores the diagonal and the  *
!*               columns ld+1, .., ld+ud contain the upper            *
!*               co-diagonals.                                        *
!*      perm     integer perm(0:n-1) : row permutation vector         *
!*      signd    integer signd (value: 1 or -1)                       *
!*               sign of perm. The determinant of A can be computed   *
!*               as the product of the diagonal entries times signd.  *
!*                                                                    *
!*   Output parameters:                                               *
!*   ------------------                                               *
!*      pmat     REAL*8 pmat(0:n-1,0:n-1)                             *
!*               LU factorization in condensed form                   *
!*      perm     integer perm(0:n-1)                                  *
!*               row permutation vector                               *
!*      signd    integer signd : sign of perm                         *
!*                                                                    *
!*   Return value :                                                   *
!*   -------------                                                    *
!*      = 0      all ok                                               *
!*      = 1      n < 3 or other incorrect input parameter             *
!*      = 2      not used here                                        *
!*      = 3      Matrix is numerically singular                       *
!*                                                                    *
!*   Function used : user defined SWAP()                              *
!*   -------------                                                    *
!======================================================================
  INTEGER j0, mm, up, istart, iend, step, kstart,kend, kjend, km, jm, jk
  INTEGER k, j, i, ii
  REAL*8 piv

  if (ld < 0.or.ud < 0.or.n < 1) then
    code=1                              ! Invalid input parameter
    return
  end if

  mm = ld + 1 + ud + min (ld, ud);

  if (ld <= ud) then                   ! up = 0 ==> transform integero
    up=1                               ! lower triangular matrix
  else
    up=0
  end if

  do i = 0, n-1
    do k = ld + ud + 1, mm-1           ! initialize needed extra
      pmat(i,k) = 0.D0                 ! columns
    end do
  end do

  signd = 1                               ! initialize signd
  if (up.eq.1) then
    istart = 0; iend = n-1; step = 1      ! Find start, end and
    kstart = 1                            ! directions of loops                                             ! depending of up
  else
    istart = n-1; iend = 0; step = -1
    kstart = -1
  end if

  i = istart
  do while (i.ne.iend)
    !kend = (up ? min (ld+1, n-i) : max (-i-1, -ud-1));
    if (up.eq.1) then
	  kend = min (ld+1, n-i)
    else
	  kend = max (-i-1, -ud-1)
    end if

    j0 = 0
    piv = DABS (pmat(i,ld))                ! choose pivot

    k=kstart
    do while (k.ne.kend)
      if (DABS(pmat(k+i,ld-k)) > piv)  then
        piv = DABS(pmat(k+i,ld-k))
        j0 = k
      end if
      k = k + step
    end do

    if (piv < MACH_EPS) then
      code = 3                            ! If piv = 0, matrix is
      return                              ! singular
    end if

    perm(i) = j0
    !kjend =  (up ? min (j0+ud+1, n-i) : max ( -i-1, j0-ld-1));
    if (up.eq.1) then
	  kjend = min (j0+ud+1, n-i)
    else
	  kjend = max ( -i-1, j0-ld-1)
    end if

    if (j0.ne.0) then
      signd = - signd                     ! swap rows
      k = 0
      do while (k.ne.kjend)
        km = k + ld
        if (km < 0) then
		  km = km + mm
        end if

        call SWAP(pmat(i,km), pmat(i+j0,k+ld-j0))  !see basis_r.f90

        k = k + step
      end do
    end if

    k = kstart
    do while (k.ne.kend)
                                                   ! below row i
      pmat(k+i,ld-k) = pmat(k+i,ld-k) / pmat(i,ld)
      j=kstart
      do while (j.ne.kjend)
                                                   ! loop over all
        jk = j + ld - k                            ! columns right of i
        jm = j + ld
                                      ! additional columns from pivoting
        if (jk < 0) then              ! are stored to right of column
		  jk = jk +mm
        end if
        if (jm < 0) then
		  jm = jm + mm                !  ud+ld+1
        end if

        pmat(k+i,jk) = pmat(k+i,jk) - pmat(k+i,ld-k) * pmat(i,jm)

        j = j + step
      end do  ! while j
	  k = k + step
    end do  ! do while k
	i = i + step
  end do  ! do while i

  if (up.eq.1) then
    ii = n-1
  else
    ii=0
  end if

  piv = DABS (pmat(ii,ld))                     ! choose pivot
                                               ! If piv = 0, matrix is
  if (piv < MACH_EPS) then                     ! singular
    code=3
    return
  end if

  perm(iend)=0.d0
  code = 0
  return
  end

  Subroutine bandsol(n,ld,ud,pmat,b,perm,code)
  PARAMETER(MACH_EPS=1.D-15)
  INTEGER code,ud,perm(0:n-1)
  REAL*8 pmat(0:n-1,0:n-1),b(0:n-1)
!======================================================================
!*                                                                    *
!*  The subroutine bandsol solves a factored linear banded system in  *
!*  condensed form using banddec.                                     *
!*                                                                    *
!* ------------------------------------------------------------------ *
!*                                                                    *
!*   Input parameters:                                                *
!*   -----------------                                                *
!*      n        integer n;  ( n > 2 )                                *
!*               Dimension of pmat, size of b                         *
!*      ld       integer ld; ( ld >= 0 )                              *
!*               number of lower co-diagonals                         *
!*      ud       integer ud; ( ud >= 0 )                              *
!*               number of upper co-diagonals                         *
!*      pmat     REAL*8  pmat(0:n-1,0:n-1)                            *
!*               Matrices for the factored system in comndensed form. *
!*      perm     integer perm(0:n-1)                                  *
!*               row permutation vector                               *
!*                                                                    *
!*   Output parameters:                                               *
!*   ------------------                                               *
!*      b        REAL*8 b(0:n-1)                                      *
!*               solution vector of linear system                     *
!*                                                                    *
!*   Return value :                                                   *
!*   -------------                                                    *
!*      = 0      all ok                                               *
!*      = 1      n < 3 or other incorrect input parameter             *
!*                                                                    *
!======================================================================
  INTEGER i, k, s, mm, up, istart, iend, step, kstart, kend, km

  if (ld < 0.or.ud < 0.or.n < 1) then    ! invalid input
    code = 1
    return
  end if

  mm = ld + ud + 1 + min (ld, ud)        ! mm = max. column number

  if (ld <= ud) then                     ! up = 0 ==> transform into
    up=1                                 ! lower triangular matrix
  else
    up=0
  end if

  if (up.eq.1) then
    istart = 0; iend = n-1; step = 1     ! determine bounds and
    kstart = 1; s = -1                   ! direction of loop
  else                                   ! depending on up
    istart = n-1; iend = 0; step = -1
    kstart = -1; s = 1
  end if

  i=istart
  do while (i.ne.iend)
    if (perm(i).ne.0) then
      call SWAP( b(i), b(i+perm(i)))
    end if

    !kend = (up ? min (ld+1, n-i) : max (-i-1, -ud-1));
    if (up.eq.1) then
	  kend = min(ld+1, n-i)
    else
	  kend = max(-i-1, -ud-1)
    end if

    k=kstart
    do while (k.ne.kend)
      b(k+i) = b(k+i) - pmat(k+i,ld-k) * b(i)
      k=k+step
    end do
    i=i+step
  end do

  i=iend
  do while (i.ne.istart+s)
    !kend =  (up ? min (ld+ud+1, n-i) : max (-i-1, -ud-ld));
    if (up.eq.1) then
	  kend = min(ld+ud+1, n-i)
    else
	  kend = max(-i-1, -ud-ld)
    end if

    k=kstart
    do while (k.ne.kend)
      km = k + ld                      ! update and
      if (km < 0) km = km + mm         ! back substitute
      b(i) = b(i) - pmat(i,km) * b(i+k)
      k=k+step
    end do
    if (DABS(pmat(i,ld)) > MACH_EPS) then
      b(i) = b(i) / pmat(i,ld)
    else
      b(i)=0.d0
    end if
    i=i-step
  end do

  code = 0
  return
  end  !bandsol

!***********************
! Swap two real values
!***********************
  Subroutine Swap(a,b)
  REAL*8 a,b,temp
  temp=a
  a=b
  b=temp
  return
  end subroutine Swap

! --------------------------- END fband.f90 -------------------------


module mandelbrot
	use, intrinsic :: ISO_C_BINDING

	implicit none

	! create arrays for mandelbrot calculations
	!   'prev' stores value of z from last iteration
	complex(8), dimension(:,:), pointer :: z, c, prev
	! create array for tracking which values need to
	!   be updated next iteration
	logical, dimension(:,:), pointer :: active
	! dimensions of data
	integer :: r_count, i_count

	contains

	subroutine mandelbrot_init(r_size, i_size) bind(C)
		! this subroutine allocates memory for the arrays
		implicit none

		! args are integers - from C, so they are values
		!   not pointers
		integer(C_INT), value :: r_size, i_size

		! allocate memory for the arrays
		allocate(c(r_size, i_size))
		allocate(z(r_size, i_size))
		allocate(prev(r_size, i_size))
		allocate(active(r_size, i_size))

		! store the dimensions
		r_count = r_size
		i_count = i_size
	end subroutine

	subroutine set_region(r_min, r_max, i_min, i_max) bind(C)
		! this function sets the area of the mandelbrot set
		!   to calculate, and resets the working variables
		implicit none

		! args are C doubles, so values not pointers
		real(C_DOUBLE), value :: r_min, r_max, i_min, i_max
		! this array will store the range of real vals
		real(8), dimension(r_count) :: real_vals
		! this array will store the range of imaginary vals
		real(8), dimension(i_count) :: imag_vals
		! these two doubles are the step between values
		real(8) :: real_interval, imag_interval
		! these ints are iteration variables
		integer :: r, i

		! calculate step sizes
		real_interval = (r_max - r_min) / r_count
		imag_interval = (i_max - i_min) / i_count

		! create values for real components
		real_vals = (/((real_interval * i), i=1,r_count)/)
		real_vals = real_vals + r_min
		! create values for imag components
		imag_vals = (/((imag_interval * i), i=1,i_count)/)
		imag_vals = imag_vals + i_min

		! iterate over the array
		do r=1,r_count
			do i=1,i_count
				! set each value of 'c'
				c(r, i) = cmplx(real_vals(r), imag_vals(i))
			end do
		end do

		! reset the 'active' array
		active = .true.
		! reset 'z' and 'prev'
		z = cmplx(0, 0)
		prev = z
	end subroutine

	subroutine update(changed) bind(C)
		! this function iterates the mandelbrot algorithm and
		!   returns which cells have left the set this iter.
		implicit none
		! the argument is a C boolean array
		logical(C_BOOL), dimension(r_count, i_count), intent(inout) :: changed

		! only update where we need to
		where (active)
			! compute new value for 'z'
			z = (z * z) + c
			! if the new value is outside the set,
			!   set its cell in 'changed' to 'true'
			changed = abs(z) > 2
		elsewhere
			! if it isn't active then it can't have changed
			changed = .false.
		end where

		! everywhere that has been changed no longer
		!   needs to be updated, so set active to 'false'
		where (changed)
			active = .false.
		end where

		! if the value of 'z' hasn't changed from last
		!   iteration and cell is still active, then
		!   set active to 'false'
		where ((z .eq. prev) .and. active)
			active = .false.
		end where

		! update previous values
		prev = z
	end subroutine

	subroutine update_colours(updates, colour, surface) bind(C)
		! this function sets all values in 'surface' which
		!   correspond to the changes in 'updates' to 'colour'
		implicit none

		! 'updates' is a C boolean array
		logical(C_BOOL), dimension(r_count, i_count), intent(inout) :: updates
		! 'surface' is an array of C ints
		integer(C_INT), dimension(r_count, i_count), intent(inout) :: surface
		! 'colour' is a C int
		integer(C_INT), value :: colour

		! everywhere that's changed needs to have a colour set
		where(updates)
			surface = colour
		end where
	end subroutine

	subroutine reset_changes(updates) bind(C)
		! resets the 'updates' array
		implicit none

		logical(C_BOOL), dimension(r_count, i_count), intent(inout) :: updates

		updates = .true.
	end subroutine
end module


    Program zgesvj_example

!     ZGESVJ Example Program Text

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

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_complex_gen
      Use lapack_interfaces, Only: ddisna, zgesvj
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: eps, serrbd
      Integer :: i, ifail, info, j, lda, ldv, lrwork, lwork, m, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), cwork(:), v(:, :)
      Real (Kind=dp), Allocatable :: rcondu(:), rcondv(:), rwork(:), sva(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, epsilon, max, nint
!     .. Executable Statements ..
      Write (nout, *) 'ZGESVJ Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n
      lda = m
      ldv = n
      lwork = n + m
      lrwork = max(6, n)
      Allocate (a(lda,n), rcondu(m), rcondv(m), sva(n), v(ldv,n), &
        cwork(lwork), rwork(lrwork))

!     Read the m by n matrix A from data file

      Read (nin, *)((a(i,j),j=1,n), i=1, m)

!     Compute the singular values and left and right singular vectors
!     of A (A = U*S*V, m.ge.n)

      Call zgesvj('G', 'U', 'V', m, n, a, lda, sva, 0, v, ldv, cwork, lwork, &
        rwork, lrwork, info)
      If (info==0) Then

!       Compute the approximate error bound for the computed singular values
!       using the 2-norm, s(1) = norm(A), and machine precision, eps.
        eps = epsilon(1.0E0_dp)
        serrbd = eps*sva(1)

!       Print solution
        Write (nout, *) 'Singular values'
        Write (nout, 100)(sva(j), j=1, n)

        If (abs(rwork(1)-1.0_dp)>eps) Then
          Write (nout, 130) 'Values need scaling by factor = ', rwork(1)
        End If
        Write (nout, *)
        Flush (nout)

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_complex_gen('General', ' ', m, n, a, lda, &
          'Left singular vectors', ifail)

        Write (nout, *)
        Flush (nout)

        ifail = 0
        Call nagf_file_print_matrix_complex_gen('General', ' ', n, n, v, ldv, &
          'Right singular vectors', ifail)

!       Call DDISNA to estimate reciprocal condition
!       numbers for the singular vectors
        Call ddisna('Left', m, n, sva, rcondu, info)
        Call ddisna('Right', m, n, sva, rcondv, info)

!       Print the approximate error bounds for the singular values
!       and vectors
        Write (nout, '(/1X,A)') &
          'Error estimates (as multiples of machine precision):'
        Write (nout, '(/1X,A)') '  for the singular values'
        Write (nout, 110) nint(serrbd/epsilon(1.0E0_dp))
        Write (nout, '(/1X,A)') '  for left singular vectors'
        Write (nout, 110)(nint(serrbd/rcondu(i)/epsilon(1.0E0_dp)), i=1, n)
        Write (nout, '(/1X,A)') '  for right singular vectors'
        Write (nout, 110)(nint(serrbd/rcondv(i)/epsilon(1.0E0_dp)), i=1, n)
      Else
        Write (nout, 120) 'Failure in ZGESVJ. INFO =', info
      End If

100   Format (3X, (8F8.4))
110   Format (4X, 6I4)
120   Format (1X, A, I4)
130   Format (/, 1X, A, 1P, E13.5)
    End Program


SUBROUTINE ecmat(ecm,fun,ndof,nodof)
!
! This subroutine forms the element consistent mass matrix.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::fun(:)
 REAL(iwp),INTENT(OUT)::ecm(:,:)
 INTEGER,INTENT(IN)::nodof,ndof
 INTEGER::nod,i,j
 REAL::nt(ndof,nodof),tn(nodof,ndof),zero=0.0_iwp
 nod=ndof/nodof
 nt=zero
 tn=zero
 DO i=1,nod
   DO j=1,nodof
     nt((i-1)*nodof+j,j)=fun(i)
     tn(j,(i-1)*nodof+j)=fun(i)
   END DO
 END DO
 ecm=MATMUL(nt,tn)
RETURN
END SUBROUTINE ecmat


*DECK CPQR79
      SUBROUTINE CPQR79 (NDEG, COEFF, ROOT, IERR, WORK)
C***BEGIN PROLOGUE  CPQR79
C***PURPOSE  Find the zeros of a polynomial with complex coefficients.
C***LIBRARY   SLATEC
C***CATEGORY  F1A1B
C***TYPE      COMPLEX (RPQR79-S, CPQR79-C)
C***KEYWORDS  COMPLEX POLYNOMIAL, POLYNOMIAL ROOTS, POLYNOMIAL ZEROS
C***AUTHOR  Vandevender, W. H., (SNLA)
C***DESCRIPTION
C
C   Abstract
C       This routine computes all zeros of a polynomial of degree NDEG
C       with complex coefficients by computing the eigenvalues of the
C       companion matrix.
C
C   Description of Parameters
C       The user must dimension all arrays appearing in the call list
C            COEFF(NDEG+1), ROOT(NDEG), WORK(2*NDEG*(NDEG+1))
C
C    --Input--
C      NDEG    degree of polynomial
C
C      COEFF   COMPLEX coefficients in descending order.  i.e.,
C              P(Z)= COEFF(1)*(Z**NDEG) + COEFF(NDEG)*Z + COEFF(NDEG+1)
C
C      WORK    REAL work array of dimension at least 2*NDEG*(NDEG+1)
C
C   --Output--
C      ROOT    COMPLEX vector of roots
C
C      IERR    Output Error Code
C           - Normal Code
C          0  means the roots were computed.
C           - Abnormal Codes
C          1  more than 30 QR iterations on some eigenvalue of the
C             companion matrix
C          2  COEFF(1)=0.0
C          3  NDEG is invalid (less than or equal to 0)
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  COMQR, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   791201  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   911010  Code reworked and simplified.  (RWC and WRB)
C***END PROLOGUE  CPQR79
      COMPLEX COEFF(*), ROOT(*), SCALE, C
      REAL WORK(*)
      INTEGER NDEG, IERR, K, KHR, KHI, KWR, KWI, KAD, KJ
C***FIRST EXECUTABLE STATEMENT  CPQR79
      IERR = 0
      IF (ABS(COEFF(1)) .EQ. 0.0) THEN
         IERR = 2
         CALL XERMSG ('SLATEC', 'CPQR79',
     +      'LEADING COEFFICIENT IS ZERO.', 2, 1)
         RETURN
      ENDIF
C
      IF (NDEG .LE. 0) THEN
         IERR = 3
         CALL XERMSG ('SLATEC', 'CPQR79', 'DEGREE INVALID.', 3, 1)
         RETURN
      ENDIF
C
      IF (NDEG .EQ. 1) THEN
         ROOT(1) = -COEFF(2)/COEFF(1)
         RETURN
      ENDIF
C
      SCALE = 1.0E0/COEFF(1)
      KHR = 1
      KHI = KHR+NDEG*NDEG
      KWR = KHI+KHI-KHR
      KWI = KWR+NDEG
C
      DO 10 K=1,KWR
         WORK(K) = 0.0E0
   10 CONTINUE
C
      DO 20 K=1,NDEG
         KAD = (K-1)*NDEG+1
         C = SCALE*COEFF(K+1)
         WORK(KAD) = -REAL(C)
         KJ = KHI+KAD-1
         WORK(KJ) = -AIMAG(C)
         IF (K .NE. NDEG) WORK(KAD+K) = 1.0E0
   20 CONTINUE
C
      CALL COMQR (NDEG,NDEG,1,NDEG,WORK(KHR),WORK(KHI),WORK(KWR),
     1   WORK(KWI),IERR)
C
      IF (IERR .NE. 0) THEN
         IERR = 1
         CALL XERMSG ('SLATEC', 'CPQR79',
     +      'NO CONVERGENCE IN 30 QR ITERATIONS.', 1, 1)
         RETURN
      ENDIF
C
      DO 30 K=1,NDEG
         KM1 = K-1
         ROOT(K) = CMPLX(WORK(KWR+KM1),WORK(KWI+KM1))
   30 CONTINUE
      RETURN
      END


program main
	integer :: chosen(4)
	integer :: ssize

	character(len=50) :: donuts(4) = [ "iced", "jam", "plain", "something completely different" ]

	ssize = choose( chosen, 2, 3 )
	write(*,*) "Total = ", ssize

	contains

	recursive function choose( got, len, maxTypes, nChosen, at ) result ( output )
		integer :: got(:)
		integer :: len
		integer :: maxTypes
		integer :: output
		integer, optional :: nChosen
		integer, optional :: at

		integer :: effNChosen
		integer :: effAt

		integer :: i
		integer :: counter

		effNChosen = 1
		if( present(nChosen) ) effNChosen = nChosen

		effAt = 1
		if( present(at) ) effAt = at

		if ( effNChosen == len+1 ) then
			do i=1,len
				write(*,"(A10,5X)", advance='no') donuts( got(i)+1 )
			end do

			write(*,*) ""

			output = 1
			return
		end if

		counter = 0
		do i=effAt,maxTypes
			got(effNChosen) = i-1
			counter = counter + choose( got, len, maxTypes, effNChosen + 1, i )
		end do

		output = counter
		return
	end function choose

end program main


      subroutine wsqrt(xr,xi,yr,yi)
*
*     PURPOSE
*        wsqrt compute the square root of a complex number
*        y = yr + i yi = sqrt(x), x = xr + i xi
*
*     CALLING LIST / PARAMETERS
*        subroutine wsqrt(xr,xi,yr,yi)
*        double precision xr,xi,yr,yi
*
*        xr,xi: real and imaginary parts of the complex number
*        yr,yi: real and imaginary parts of the result
*               yr,yi may have the same memory cases than xr et xi
*
*     ALGORITHM
*        essentially the classic one which consists in
*        choosing the good formula such as avoid cancellation ;
*        Also rare spurious overflow are treated with a
*        "manual" method. For some more "automated" methods
*        (but currently difficult to implement in a portable
*        way) see :
*
*          Hull, Fairgrieve, Tang,
*          "Implementing Complex Elementary Functions Using
*          Exception Handling", ACM TOMS, Vol. 20 (1994), pp 215-244
*
*        for xr > 0 :
*          yr = sqrt(2( xr + sqrt( xr^2 + xi^2)) )/ 2
*          yi = xi / sqrt(2(xr + sqrt(xr^2 + xi^2)))
*
*        and for xr < 0 :
*          yr = |xi| / sqrt( 2( -xr + sqrt( xr^2 + xi^2 )) )
*          yi = sign(xi) sqrt(2(-xr + sqrt( xr^2 + xi^2))) / 2
*
*        for xr = 0 use
*          yr = sqrt(0.5)*sqrt(|xi|)  when |xi| is such that 0.5*|xi| may underflow
*             = sqrt(0.5*|xi|)        else
*          yi = sign(xi) yr
*
*        Noting t = sqrt( 2( |xr| + sqrt( xr^2 + yr^2)) )
*                 = sqrt( 2( |xr| + pythag(xr,xi) ) )
*        it comes :
*
*          for xr > 0   |  for xr < 0
*         --------------+---------------------
*           yr = 0.5*t  |  yr =  |xi| / t
*           yi = xi / t |  yi = sign(xi)*0.5* t
*
*        as the function pythag must not underflow (and overflow only
*        if sqrt(x^2+y^2) > rmax) only spurious (rare) case of overflow
*        occurs in which case a scaling is done.
*
      implicit none

*     PARAMETER
      double precision xr, xi, yr, yi

*     LOCAL VAR
      double precision a, b, t
*     EXTERNAL

      double precision pythag, dlamch

      external         pythag, dlamch

      integer          isanan

      external         isanan

*     STATIC VAR
      logical first
      double precision RMAX, BRMIN

      save    first
      data    first /.true./
      save    RMAX, BRMIN

      if (first) then
         RMAX = dlamch('O')
         BRMIN = 2.d0*dlamch('U')
         first = .false.
      endif

      a = xr
      b = xi

      if ( a .eq. 0.d0 ) then
*        pure imaginary case
         if ( abs(b) .ge. BRMIN ) then
            yr = sqrt(0.5d0*abs(b))
         else
            yr = sqrt(abs(b))*sqrt(0.5d0)
         endif
         yi = sign(1.d0, b)*yr

      elseif ( abs(a).le.RMAX .and. abs(b).le.RMAX ) then
*        standard case : a (not zero) and b are finite
         t = sqrt(2.d0*(abs(a) + pythag(a,b)))
*        overflow test
         if ( t .gt. RMAX ) goto 100
*        classic switch to get the stable formulas
         if ( a .ge. 0.d0 ) then
            yr = 0.5d0*t
            yi = b/t
         else
            yr = abs(b)/t
            yi = sign(0.5d0,b)*t
         endif
      else
*        Here we treat the special cases where a and b are +- 00 or NaN.
*        The following is the treatment recommended by the C99 standard
*        with the simplification of returning NaN + i NaN if the
*        the real part or the imaginary part is NaN (C99 recommends
*        something more complicated)
         if ( (isanan(a) .eq. 1) .or. (isanan(b) .eq. 1) ) then
*           got NaN + i NaN
            yr = a + b
            yi = yr
         elseif ( abs(b) .gt. RMAX ) then
*           case a +- i oo -> result must be +oo +- i oo  for all a (finite or not)
            yr = abs(b)
            yi = b
         elseif ( a .lt. -RMAX ) then
*           here a is -Inf and b is finite
            yr = 0.d0
            yi = sign(1.d0,b)*abs(a)
         else
*           here a is +Inf and b is finite
            yr = a
            yi = 0.d0
         endif
      endif

      return

*     handle (spurious) overflow by scaling a and b
 100  continue
      a = a/16.d0
      b = b/16.d0
      t = sqrt(2.d0*(abs(a) + pythag(a,b)))
      if ( a .ge. 0.d0 ) then
         yr = 2.d0*t
         yi = 4.d0*b/t
      else
         yr = 4.d0*abs(b)/t
         yi = sign(2.d0,b)*t
      endif

      end


FUNCTION area_circle(r)
IMPLICIT NONE

REAL*8, PARAMETER :: Pi = 3.1415927
REAL*8, INTENT(IN) :: r
REAL*8 :: area_circle

area_circle = Pi * r * r
RETURN

END FUNCTION area_circle


! More examples of calling C to process matrices are in xxmat.f90
module matrix_mod
use iso_c_binding, only: c_int, c_float
implicit none
interface
pure subroutine sum_cols(nrow_c,ncol_c,x,col_sums) bind(c,name="sum_rows")
! C function to compute row sums computes column sums of Fortran matrix
import c_int, c_float
integer(kind=c_int), intent(in), value :: nrow_c, ncol_c
real(kind=c_float) , intent(in)        :: x(ncol_c,nrow_c)
real(kind=c_float) , intent(out)       :: col_sums(nrow_c)
end subroutine sum_cols
end interface
!
contains
pure function column_sums(x) result(col_sums) ! wrap sum_cols
real(kind=c_float), intent(in) :: x(:,:)
real(kind=c_float) :: col_sums(size(x,2))
call sum_cols(size(x,2),size(x,1),x,col_sums)
end function column_sums
end module matrix_mod

program xcol_sum
use matrix_mod, only: c_float, sum_cols, column_sums
implicit none
integer, parameter :: nr = 2, nc = 3
real(kind=c_float) :: x(nr,nc),col_sums(nc)
integer            :: ir,ic
character (len=20) :: fmt="(a,*(1x,f5.1))"
print*,"matrix"
do ir=1,nr
   forall (ic=1:nc) x(ir,ic) = real(10*ir + ic, kind = c_float)
   print "(*(1x,f5.1))",x(ir,:)
end do
! call subroutine with explicit-shape array arguments
call sum_cols(nrow_c=nc, ncol_c=nr, x=x, col_sums=col_sums)
print fmt,"col_sums=",col_sums
! call function with assumed-shape argument -- simpler
print fmt,"col_sums=",column_sums(x)
end program xcol_sum
! Compile with
!   gcc -c -o sum_rows.o sum_rows.c
!   gfortran sum_rows.o xcol_sum.f90
! output:
!  matrix
!   11.0  12.0  13.0
!   21.0  22.0  23.0
! col_sums=  32.0  34.0  36.0
! col_sums=  32.0  34.0  36.0


MODULE FUN_xyCENTROID
!!#### PURPOSE
!! Calculate the centroid (center-of-mass) of various shapes:
!!  1. polygon <Pg>

!!#### EXTERNAL PARAMETERS
USE PAR_ComputationalGeometry,ONLY: xySHAPE_Ls,xySHAPE_Pg,xySHAPE_P !!((02-A-PAR_ComputationalGeometry.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyCENTROID_Pg
 MODULE PROCEDURE xyCENTROID_Pg_Rsp
 MODULE PROCEDURE xyCENTROID_Pg_Rdp
END INTERFACE

INTERFACE xyCENTROID_Ls
 MODULE PROCEDURE xyCENTROID_Ls_Rsp
 MODULE PROCEDURE xyCENTROID_Ls_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyCENTROID_Pg
PUBLIC :: xyCENTROID_Ls

CONTAINS

PURE FUNCTION xyCENTROID_Ls_Rsp( Ls ) RESULT(xyP)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                       !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rsp,ONLY: c_1_by_2                                !!((02-A-PAR_Constants_Rsp.f90))
INCLUDE "05-B-FUN_xyCENTROID_Ls.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyCENTROID_Ls.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyCENTROID_Ls_Rdp( Ls ) RESULT(xyP)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                       !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rdp,ONLY: c_1_by_2                                !!((02-A-PAR_Constants_Rdp.f90))
INCLUDE "05-B-FUN_xyCENTROID_Ls.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyCENTROID_Ls.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyCENTROID_Pg_Rsp( N , Pg , AREA ) RESULT(xyP)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp                       !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rsp,ONLY: c_1_by_6                                !!((02-A-PAR_Constants_Rsp.f90))
INCLUDE "05-B-FUN_xyCENTROID_Pg.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyCENTROID_Pg.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyCENTROID_Pg_Rdp( N , Pg , AREA ) RESULT(xyP)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp                       !!((01-A-KND_IntrinsicTypes.f90))
USE PAR_Constants_Rdp,ONLY: c_1_by_6                                !!((02-A-PAR_Constants_Rdp.f90))
INCLUDE "05-B-FUN_xyCENTROID_Pg.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_xyCENTROID_Pg.f90.bdy"
!!--end--
END FUNCTION

END MODULE


       double precision FUNCTION DIFF(X,Y)
c
c  Function used in tests that depend on machine precision.
c
c  The original version of this code was developed by
c  Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory
c  1973 JUN 7, and published in the book
c  "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974.
c  Revised FEB 1995 to accompany reprinting of the book by SIAM.
C
      double precision X, Y
      DIFF=X-Y
      RETURN
      END

      SUBROUTINE G1 (A,B,CTERM,STERM,SIG)
c
C     COMPUTE ORTHOGONAL ROTATION MATRIX..
c
c  The original version of this code was developed by
c  Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory
c  1973 JUN 12, and published in the book
c  "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974.
c  Revised FEB 1995 to accompany reprinting of the book by SIAM.
C
C     COMPUTE.. MATRIX   (C, S) SO THAT (C, S)(A) = (SQRT(A**2+B**2))
C                        (-S,C)         (-S,C)(B)   (   0          )
C     COMPUTE SIG = SQRT(A**2+B**2)
C        SIG IS COMPUTED LAST TO ALLOW FOR THE POSSIBILITY THAT
C        SIG MAY BE IN THE SAME LOCATION AS A OR B .
C     ------------------------------------------------------------------
      double precision A, B, CTERM, ONE, SIG, STERM, XR, YR, ZERO
      parameter(ONE = 1.0d0, ZERO = 0.0d0)
C     ------------------------------------------------------------------
      if (abs(A) .gt. abs(B)) then
         XR=B/A
         YR=sqrt(ONE+XR**2)
         CTERM=sign(ONE/YR,A)
         STERM=CTERM*XR
         SIG=abs(A)*YR
         RETURN
      endif

      if (B .ne. ZERO) then
         XR=A/B
         YR=sqrt(ONE+XR**2)
         STERM=sign(ONE/YR,B)
         CTERM=STERM*XR
         SIG=abs(B)*YR
         RETURN
      endif

      SIG=ZERO
      CTERM=ZERO
      STERM=ONE
      RETURN
      END

C     SUBROUTINE H12 (MODE,LPIVOT,L1,M,U,IUE,UP,C,ICE,ICV,NCV)
C
C  CONSTRUCTION AND/OR APPLICATION OF A SINGLE
C  HOUSEHOLDER TRANSFORMATION..     Q = I + U*(U**T)/B
C
c  The original version of this code was developed by
c  Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory
c  1973 JUN 12, and published in the book
c  "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974.
c  Revised FEB 1995 to accompany reprinting of the book by SIAM.
C     ------------------------------------------------------------------
c                     Subroutine Arguments
c
C     MODE   = 1 OR 2   Selects Algorithm H1 to construct and apply a
c            Householder transformation, or Algorithm H2 to apply a
c            previously constructed transformation.
C     LPIVOT IS THE INDEX OF THE PIVOT ELEMENT.
C     L1,M   IF L1 .LE. M   THE TRANSFORMATION WILL BE CONSTRUCTED TO
C            ZERO ELEMENTS INDEXED FROM L1 THROUGH M.   IF L1 GT. M
C            THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION.
C     U(),IUE,UP    On entry with MODE = 1, U() contains the pivot
c            vector.  IUE is the storage increment between elements.
c            On exit when MODE = 1, U() and UP contain quantities
c            defining the vector U of the Householder transformation.
c            on entry with MODE = 2, U() and UP should contain
c            quantities previously computed with MODE = 1.  These will
c            not be modified during the entry with MODE = 2.
C     C()    ON ENTRY with MODE = 1 or 2, C() CONTAINS A MATRIX WHICH
c            WILL BE REGARDED AS A SET OF VECTORS TO WHICH THE
c            HOUSEHOLDER TRANSFORMATION IS TO BE APPLIED.
c            ON EXIT C() CONTAINS THE SET OF TRANSFORMED VECTORS.
C     ICE    STORAGE INCREMENT BETWEEN ELEMENTS OF VECTORS IN C().
C     ICV    STORAGE INCREMENT BETWEEN VECTORS IN C().
C     NCV    NUMBER OF VECTORS IN C() TO BE TRANSFORMED. IF NCV .LE. 0
C            NO OPERATIONS WILL BE DONE ON C().
C     ------------------------------------------------------------------
      SUBROUTINE H12 (MODE,LPIVOT,L1,M,U,IUE,UP,C,ICE,ICV,NCV)
C     ------------------------------------------------------------------
      integer I, I2, I3, I4, ICE, ICV, INCR, IUE, J
      integer L1, LPIVOT, M, MODE, NCV
      double precision B, C(*), CL, CLINV, ONE, SM
c     double precision U(IUE,M)
      double precision U(IUE,*)
      double precision UP
      parameter(ONE = 1.0d0)
C     ------------------------------------------------------------------
      IF (0.GE.LPIVOT.OR.LPIVOT.GE.L1.OR.L1.GT.M) RETURN
      CL=abs(U(1,LPIVOT))
      IF (MODE.EQ.2) GO TO 60
C                            ****** CONSTRUCT THE TRANSFORMATION. ******
          DO 10 J=L1,M
   10     CL=MAX(abs(U(1,J)),CL)
      IF (CL) 130,130,20
   20 CLINV=ONE/CL
      SM=(U(1,LPIVOT)*CLINV)**2
          DO 30 J=L1,M
   30     SM=SM+(U(1,J)*CLINV)**2
      CL=CL*SQRT(SM)
      IF (U(1,LPIVOT)) 50,50,40
   40 CL=-CL
   50 UP=U(1,LPIVOT)-CL
      U(1,LPIVOT)=CL
      GO TO 70
C            ****** APPLY THE TRANSFORMATION  I+U*(U**T)/B  TO C. ******
C
   60 IF (CL) 130,130,70
   70 IF (NCV.LE.0) RETURN
      B= UP*U(1,LPIVOT)
C                       B  MUST BE NONPOSITIVE HERE.  IF B = 0., RETURN.
C
      IF (B) 80,130,130
   80 B=ONE/B
      I2=1-ICV+ICE*(LPIVOT-1)
      INCR=ICE*(L1-LPIVOT)
          DO 120 J=1,NCV
          I2=I2+ICV
          I3=I2+INCR
          I4=I3
          SM=C(I2)*UP
              DO 90 I=L1,M
              SM=SM+C(I3)*U(1,I)
   90         I3=I3+ICE
          IF (SM) 100,120,100
  100     SM=SM*B
          C(I2)=C(I2)+SM*UP
              DO 110 I=L1,M
              C(I4)=C(I4)+SM*U(1,I)
  110         I4=I4+ICE
  120     CONTINUE
  130 RETURN
      END

C     SUBROUTINE NNLS  (A,MDA,M,N,B,X,RNORM,W,ZZ,INDEX,MODE)
C
C  Algorithm NNLS: NONNEGATIVE LEAST SQUARES
C
c  The original version of this code was developed by
c  Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory
c  1973 JUN 15, and published in the book
c  "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974.
c  Revised FEB 1995 to accompany reprinting of the book by SIAM.
c
C     GIVEN AN M BY N MATRIX, A, AND AN M-VECTOR, B,  COMPUTE AN
C     N-VECTOR, X, THAT SOLVES THE LEAST SQUARES PROBLEM
C
C                      A * X = B  SUBJECT TO X .GE. 0
C     ------------------------------------------------------------------
c                     Subroutine Arguments
c
C     A(),MDA,M,N     MDA IS THE FIRST DIMENSIONING PARAMETER FOR THE
C                     ARRAY, A().   ON ENTRY A() CONTAINS THE M BY N
C                     MATRIX, A.           ON EXIT A() CONTAINS
C                     THE PRODUCT MATRIX, Q*A , WHERE Q IS AN
C                     M BY M ORTHOGONAL MATRIX GENERATED IMPLICITLY BY
C                     THIS SUBROUTINE.
C     B()     ON ENTRY B() CONTAINS THE M-VECTOR, B.   ON EXIT B() CON-
C             TAINS Q*B.
C     X()     ON ENTRY X() NEED NOT BE INITIALIZED.  ON EXIT X() WILL
C             CONTAIN THE SOLUTION VECTOR.
C     RNORM   ON EXIT RNORM CONTAINS THE EUCLIDEAN NORM OF THE
C             RESIDUAL VECTOR.
C     W()     AN N-ARRAY OF WORKING SPACE.  ON EXIT W() WILL CONTAIN
C             THE DUAL SOLUTION VECTOR.   W WILL SATISFY W(I) = 0.
C             FOR ALL I IN SET P  AND W(I) .LE. 0. FOR ALL I IN SET Z
C     ZZ()     AN M-ARRAY OF WORKING SPACE.
C     INDEX()     AN INTEGER WORKING ARRAY OF LENGTH AT LEAST N.
C                 ON EXIT THE CONTENTS OF THIS ARRAY DEFINE THE SETS
C                 P AND Z AS FOLLOWS..
C
C                 INDEX(1)   THRU INDEX(NSETP) = SET P.
C                 INDEX(IZ1) THRU INDEX(IZ2)   = SET Z.
C                 IZ1 = NSETP + 1 = NPP1
C                 IZ2 = N
C     MODE    THIS IS A SUCCESS-FAILURE FLAG WITH THE FOLLOWING
C             MEANINGS.
C             1     THE SOLUTION HAS BEEN COMPUTED SUCCESSFULLY.
C             2     THE DIMENSIONS OF THE PROBLEM ARE BAD.
C                   EITHER M .LE. 0 OR N .LE. 0.
C             3    ITERATION COUNT EXCEEDED.  MORE THAN 3*N ITERATIONS.
C
C     ------------------------------------------------------------------
      SUBROUTINE NNLS (A,MDA,M,N,B,X,RNORM,W,ZZ,INDEX,MODE)
C     ------------------------------------------------------------------
      integer I, II, IP, ITER, ITMAX, IZ, IZ1, IZ2, IZMAX, J, JJ, JZ, L
      integer M, MDA, MODE,N, NPP1, NSETP, RTNKEY
c     integer INDEX(N)
c     double precision A(MDA,N), B(M), W(N), X(N), ZZ(M)
      integer INDEX(*)
      double precision A(MDA,*), B(*), W(*), X(*), ZZ(*)
      double precision ALPHA, ASAVE, CC, DIFF, DUMMY, FACTOR, RNORM
      double precision SM, SS, T, TEMP, TWO, UNORM, UP, WMAX
      double precision ZERO, ZTEST
      parameter(FACTOR = 0.01d0)
      parameter(TWO = 2.0d0, ZERO = 0.0d0)
C     ------------------------------------------------------------------
      MODE=1
      IF (M .le. 0 .or. N .le. 0) then
         MODE=2
         RETURN
      endif
      ITER=0
      ITMAX=3*N
C
C                    INITIALIZE THE ARRAYS INDEX() AND X().
C
          DO 20 I=1,N
          X(I)=ZERO
   20     INDEX(I)=I
C
      IZ2=N
      IZ1=1
      NSETP=0
      NPP1=1
C                             ******  MAIN LOOP BEGINS HERE  ******
   30 CONTINUE
C                  QUIT IF ALL COEFFICIENTS ARE ALREADY IN THE SOLUTION.
C                        OR IF M COLS OF A HAVE BEEN TRIANGULARIZED.
C
      IF (IZ1 .GT.IZ2.OR.NSETP.GE.M) GO TO 350
C
C         COMPUTE COMPONENTS OF THE DUAL (NEGATIVE GRADIENT) VECTOR W().
C
      DO 50 IZ=IZ1,IZ2
         J=INDEX(IZ)
         SM=ZERO
         DO 40 L=NPP1,M
   40        SM=SM+A(L,J)*B(L)
         W(J)=SM
   50 continue
C                                   FIND LARGEST POSITIVE W(J).
   60 continue
      WMAX=ZERO
      DO 70 IZ=IZ1,IZ2
         J=INDEX(IZ)
         IF (W(J) .gt. WMAX) then
            WMAX=W(J)
            IZMAX=IZ
         endif
   70 CONTINUE
C
C             IF WMAX .LE. 0. GO TO TERMINATION.
C             THIS INDICATES SATISFACTION OF THE KUHN-TUCKER CONDITIONS.
C
      IF (WMAX .le. ZERO) go to 350
      IZ=IZMAX
      J=INDEX(IZ)
C
C     THE SIGN OF W(J) IS OK FOR J TO BE MOVED TO SET P.
C     BEGIN THE TRANSFORMATION AND CHECK NEW DIAGONAL ELEMENT TO AVOID
C     NEAR LINEAR DEPENDENCE.
C
      ASAVE=A(NPP1,J)
      CALL H12 (1,NPP1,NPP1+1,M,A(1,J),1,UP,DUMMY,1,1,0)
      UNORM=ZERO
      IF (NSETP .ne. 0) then
          DO 90 L=1,NSETP
   90       UNORM=UNORM+A(L,J)**2
      endif
      UNORM=sqrt(UNORM)
      IF (DIFF(UNORM+ABS(A(NPP1,J))*FACTOR,UNORM) .gt. ZERO) then
C
C        COL J IS SUFFICIENTLY INDEPENDENT.  COPY B INTO ZZ, UPDATE ZZ
C        AND SOLVE FOR ZTEST ( = PROPOSED NEW VALUE FOR X(J) ).
C
         DO 120 L=1,M
  120        ZZ(L)=B(L)
         CALL H12 (2,NPP1,NPP1+1,M,A(1,J),1,UP,ZZ,1,1,1)
         ZTEST=ZZ(NPP1)/A(NPP1,J)
C
C                                     SEE IF ZTEST IS POSITIVE
C
         IF (ZTEST .gt. ZERO) go to 140
      endif
C
C     REJECT J AS A CANDIDATE TO BE MOVED FROM SET Z TO SET P.
C     RESTORE A(NPP1,J), SET W(J)=0., AND LOOP BACK TO TEST DUAL
C     COEFFS AGAIN.
C
      A(NPP1,J)=ASAVE
      W(J)=ZERO
      GO TO 60
C
C     THE INDEX  J=INDEX(IZ)  HAS BEEN SELECTED TO BE MOVED FROM
C     SET Z TO SET P.    UPDATE B,  UPDATE INDICES,  APPLY HOUSEHOLDER
C     TRANSFORMATIONS TO COLS IN NEW SET Z,  ZERO SUBDIAGONAL ELTS IN
C     COL J,  SET W(J)=0.
C
  140 continue
      DO 150 L=1,M
  150    B(L)=ZZ(L)
C
      INDEX(IZ)=INDEX(IZ1)
      INDEX(IZ1)=J
      IZ1=IZ1+1
      NSETP=NPP1
      NPP1=NPP1+1
C
      IF (IZ1 .le. IZ2) then
         DO 160 JZ=IZ1,IZ2
            JJ=INDEX(JZ)
            CALL H12 (2,NSETP,NPP1,M,A(1,J),1,UP,A(1,JJ),1,MDA,1)
  160    continue
      endif
C
      IF (NSETP .ne. M) then
         DO 180 L=NPP1,M
  180       A(L,J)=ZERO
      endif
C
      W(J)=ZERO
C                                SOLVE THE TRIANGULAR SYSTEM.
C                                STORE THE SOLUTION TEMPORARILY IN ZZ().
      RTNKEY = 1
      GO TO 400
  200 CONTINUE
C
C                       ******  SECONDARY LOOP BEGINS HERE ******
C
C                          ITERATION COUNTER.
C
  210 continue
      ITER=ITER+1
      IF (ITER .gt. ITMAX) then
         MODE=3
c         write (*,'(/a)') ' NNLS quitting on iteration count.'
         GO TO 350
      endif
C
C                    SEE IF ALL NEW CONSTRAINED COEFFS ARE FEASIBLE.
C                                  IF NOT COMPUTE ALPHA.
C
      ALPHA=TWO
      DO 240 IP=1,NSETP
         L=INDEX(IP)
         IF (ZZ(IP) .le. ZERO) then
            T=-X(L)/(ZZ(IP)-X(L))
            IF (ALPHA .gt. T) then
               ALPHA=T
               JJ=IP
            endif
         endif
  240 CONTINUE
C
C          IF ALL NEW CONSTRAINED COEFFS ARE FEASIBLE THEN ALPHA WILL
C          STILL = 2.    IF SO EXIT FROM SECONDARY LOOP TO MAIN LOOP.
C
      IF (ALPHA.EQ.TWO) GO TO 330
C
C          OTHERWISE USE ALPHA WHICH WILL BE BETWEEN 0. AND 1. TO
C          INTERPOLATE BETWEEN THE OLD X AND THE NEW ZZ.
C
      DO 250 IP=1,NSETP
         L=INDEX(IP)
         X(L)=X(L)+ALPHA*(ZZ(IP)-X(L))
  250 continue
C
C        MODIFY A AND B AND THE INDEX ARRAYS TO MOVE COEFFICIENT I
C        FROM SET P TO SET Z.
C
      I=INDEX(JJ)
  260 continue
      X(I)=ZERO
C
      IF (JJ .ne. NSETP) then
         JJ=JJ+1
         DO 280 J=JJ,NSETP
            II=INDEX(J)
            INDEX(J-1)=II
            CALL G1 (A(J-1,II),A(J,II),CC,SS,A(J-1,II))
            A(J,II)=ZERO
            DO 270 L=1,N
               IF (L.NE.II) then
c
c                 Apply procedure G2 (CC,SS,A(J-1,L),A(J,L))
c
                  TEMP = A(J-1,L)
                  A(J-1,L) = CC*TEMP + SS*A(J,L)
                  A(J,L)   =-SS*TEMP + CC*A(J,L)
               endif
  270       CONTINUE
c
c                 Apply procedure G2 (CC,SS,B(J-1),B(J))
c
            TEMP = B(J-1)
            B(J-1) = CC*TEMP + SS*B(J)
            B(J)   =-SS*TEMP + CC*B(J)
  280    continue
      endif
c
      NPP1=NSETP
      NSETP=NSETP-1
      IZ1=IZ1-1
      INDEX(IZ1)=I
C
C        SEE IF THE REMAINING COEFFS IN SET P ARE FEASIBLE.  THEY SHOULD
C        BE BECAUSE OF THE WAY ALPHA WAS DETERMINED.
C        IF ANY ARE INFEASIBLE IT IS DUE TO ROUND-OFF ERROR.  ANY
C        THAT ARE NONPOSITIVE WILL BE SET TO ZERO
C        AND MOVED FROM SET P TO SET Z.
C
      DO 300 JJ=1,NSETP
         I=INDEX(JJ)
         IF (X(I) .le. ZERO) go to 260
  300 CONTINUE
C
C         COPY B( ) INTO ZZ( ).  THEN SOLVE AGAIN AND LOOP BACK.
C
      DO 310 I=1,M
  310     ZZ(I)=B(I)
      RTNKEY = 2
      GO TO 400
  320 CONTINUE
      GO TO 210
C                      ******  END OF SECONDARY LOOP  ******
C
  330 continue
      DO 340 IP=1,NSETP
          I=INDEX(IP)
  340     X(I)=ZZ(IP)
C        ALL NEW COEFFS ARE POSITIVE.  LOOP BACK TO BEGINNING.
      GO TO 30
C
C                        ******  END OF MAIN LOOP  ******
C
C                        COME TO HERE FOR TERMINATION.
C                     COMPUTE THE NORM OF THE FINAL RESIDUAL VECTOR.
C
  350 continue
      SM=ZERO
      IF (NPP1 .le. M) then
         DO 360 I=NPP1,M
  360       SM=SM+B(I)**2
      else
         DO 380 J=1,N
  380       W(J)=ZERO
      endif
      RNORM=sqrt(SM)
      RETURN
C
C     THE FOLLOWING BLOCK OF CODE IS USED AS AN INTERNAL SUBROUTINE
C     TO SOLVE THE TRIANGULAR SYSTEM, PUTTING THE SOLUTION IN ZZ().
C
  400 continue
      DO 430 L=1,NSETP
         IP=NSETP+1-L
         IF (L .ne. 1) then
            DO 410 II=1,IP
               ZZ(II)=ZZ(II)-A(II,JJ)*ZZ(IP+1)
  410       continue
         endif
         JJ=INDEX(IP)
         ZZ(IP)=ZZ(IP)/A(IP,JJ)
  430 continue
      go to (200, 320), RTNKEY
      END


      program DRSELI
c>>1994-10-19 DRSELI Krogh  Changes to use M77CON
c>>1992-03-09 DRSELI WV Snyder Create separate single and double demos.
c>>1991-10-04 DRSELI WV Snyder JPL Original code.
c--S replaces "?": DR?ELI,?RCVAL,?ELEFI,?ELPII,?RDVAL,?RFVAL,?RJVAL
c
c     Demonstration driver for incomplete elliptic integral procedures.
c
      real             ALPHA2, E, F, K, K2, PHI, PI, R, RC, RD, RF, RJ
      real             SINPHI, T, U, X, Y, Z
      integer IERR
c
c     Compute arc sine x using ASIN and RC, for x = 0.5
c
      print *, 'Identities from write-up:'
      x = 0.5e0
      call srcval (1.0e0-x*x,1.0e0,rc,ierr)
      if (ierr.eq.0) then
         t = asin(x) - x * rc
         print '('' ASIN(0.5) - 0.5*RC(1-0.5**2,1)    ='',g15.8)', t
      else
         print '('' SRCVAL returns error signal '',i1)', ierr
      end if
c
c     Evaluate identities given by equations (8-10) in the write-up
c     with k**2 = 1/2, sin(phi)**2 = 1/4, alpha**2 = 1/2, c = 1.
c     From this, we have a = 3/4, b = r = 7/8.
c
      alpha2 = 0.5e0
      k = sqrt(0.5e0)
      k2 = 0.5e0
      sinphi = 0.5e0
      phi = asin(sinphi)
      r = 0.875e0
      x = 0.75e0
      y = 0.875e0
      z = 1.0e0
      call selefi (phi,k,f,e,ierr)
      if (ierr.ne.0) then
         print '('' SELEFI returns error signal '',i1)', ierr
         go to 99
      end if
      call selpii (phi,k2,alpha2,pi,ierr)
      if (ierr.ne.0) then
         print '('' SELPII returns error signal '',i1)', ierr
         go to 99
      end if
      call srdval (x,y,z,rd,ierr)
      if (ierr.ne.0) then
         print '('' SRDVAL returns error signal '',i1)', ierr
         go to 99
      end if
      call srfval (x,y,z,rf,ierr)
      if (ierr.ne.0) then
         print '('' SRFVAL returns error signal '',i1)', ierr
         go to 99
      end if
      call srjval (x,y,z,r,rj,ierr)
      if (ierr.ne.0) then
         print '('' SRJVAL returns error signal '',i1)', ierr
         go to 99
      end if
      u = sqrt(z**3) * rd
      t = 3.0e0 / (k2 * sinphi**3) * (f-e)
      r = (u-t) / u
      print '('' Equation (8), (LHS - RHS)/LHS     ='',g15.8)', r
      u = sqrt(z) * rf
      t = f / sinphi
      r = (u-t) / u
      print '('' Equation (9), (LHS - RHS)/LHS     ='',g15.8)', r
      u = sqrt(z**3) * rj
      t = 3 / (alpha2 * sinphi**3) * (pi - f)
      r = (u-t) / u
      print '('' Equation (10), (LHS - RHS)/LHS    ='',g15.8)', r
c
99    stop
      end


!##############################################################################
! MODULE globals
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    implicit none

    ! model parameters
    real*8, parameter :: gamma = 0.5d0
    real*8, parameter :: beta = 0.99d0
    real*8, parameter :: alpha = 0.40d0
    real*8, parameter :: delta = 0.019d0
    real*8, parameter :: k0 = 79d0
    real*8, parameter :: rho = 0.95d0
    real*8, parameter :: sigma_eps = 0.000049d0

    ! numerical parameters
    real*8, parameter :: k_l = 50d0
    real*8, parameter :: k_u = 110d0
    real*8, parameter :: sig = 1d-6
    integer, parameter :: itermax = 2000

    ! counter variables
    integer :: it, ik, is, iter

    ! time path of consumption and capital
    integer, parameter :: TT = 5000
    real*8 :: c_t(0:TT), k_t(0:TT), eta_t(0:TT)
    integer :: is_t(0:TT)

    ! the shock process
    integer, parameter :: NS = 21
    real*8 :: pi(NS, NS), eta(NS)

    ! policy function
    integer, parameter :: NK = 100
    real*8 :: k(0:NK), c(0:NK, NS)

    ! variables to numerically determine policy function
    real*8 :: c_new(0:NK, NS), coeff_c(NK+3, NS)
    real*8 :: RHS(0:NK, NS), coeff_r(NK+3, NS)
    real*8 :: con_lev, x_in
    logical :: check

    ! variables to communicate with function
    real*8 :: k_com
    integer :: is_com

contains

    ! the first order condition
    function foc(x_in)

        use toolbox

        implicit none
        real*8, intent(in) :: x_in
        real*8 :: foc, kplus

        ! future capital stock
        kplus = (1d0-delta)*k_com + exp(eta(is_com))*k_com**alpha - x_in

        ! calculate future expected marginal utility
        foc = spline_eval(min(kplus, k_u), coeff_r(:, is_com), k_l, k_u)
        if(kplus > k_u)then
            foc = foc + (RHS(NK,is_com)-RHS(NK-1,is_com))/(k(NK)-k(NK-1))*(kplus-k_u)
        endif

        ! get first order condition
        foc = x_in - foc

    end function

end module


subroutine init_phi(lo, hi, phi, philo, phihi, dx, prob_lo, prob_hi) bind(C, name="init_phi")

  use amrex_fort_module, only : amrex_real

  implicit none

  integer, intent(in) :: lo(3), hi(3), philo(3), phihi(3)
  real(amrex_real), intent(inout) :: phi(philo(1):phihi(1),philo(2):phihi(2),philo(3):phihi(3))
  real(amrex_real), intent(in   ) :: dx(3)
  real(amrex_real), intent(in   ) :: prob_lo(3)
  real(amrex_real), intent(in   ) :: prob_hi(3)

  integer          :: i,j,k
  double precision :: x,y,z,r2

  do k = lo(3), hi(3)
     z = prob_lo(3) + (dble(k)+0.5d0) * dx(3)
     do j = lo(2), hi(2)
        y = prob_lo(2) + (dble(j)+0.5d0) * dx(2)
        do i = lo(1), hi(1)
           x = prob_lo(1) + (dble(i)+0.5d0) * dx(1)

           r2 = ((x-0.25d0)**2 + (y-0.25d0)**2 + (z-0.25d0)**2) / 0.01d0
           phi(i,j,k) = 1.d0 + exp(-r2)

        end do
     end do
  end do

end subroutine init_phi


  !=====================================================
  subroutine mapc2p(xc,yc,xp,yp)
  !=====================================================
    ! Maps for sloping fault
    ! on input,  (xc,yc) is a computational grid point
    ! on output, (xp,yp) is corresponding point in physical space

    use fault_module, only: center, theta, xcb

    implicit none
    real (kind=8), intent(in) :: xc,yc
    real (kind=8), intent(out) :: xp,yp

    ! Local variables
    real (kind=8) :: ls, alpha, xrot, yrot

    if (xc < xcb(1)) then
      ls = dsqrt((xc-xcb(1))**2 + (yc-center(2))**2)
    elseif (xc > xcb(2)) then
      ls = dsqrt((xc-xcb(2))**2 + (yc-center(2))**2)
    else
      ls = dabs(yc - center(2))
    end if

    alpha = ls/(-center(2))
    xrot = center(1) + dcos(theta)*(xc-center(1)) + dsin(theta)*(yc-center(2))
    yrot = center(2) - dsin(theta)*(xc-center(1)) + dcos(theta)*(yc-center(2))

    if (alpha < 1.d0) then
      xp = (1.d0-alpha)*xrot + alpha*xc
      yp = (1.d0-alpha)*yrot + alpha*yc
    else
      xp = xc
      yp = yc
    end if

    return
    end


C

C
C
      PURE SUBROUTINE PARTS(COMP,XMOD,ANGL)
      USE PARAMETERS, ONLY : SMALLNUM, PI
      IMPLICIT NONE
C
C Dummy arguments
C
      REAL(8) :: ANGL , XMOD
      REAL(8) , DIMENSION(2) :: COMP
      INTENT (IN) COMP
      INTENT (OUT) ANGL , XMOD
C
C Local variables
C
      REAL(8) :: DABS , DATAN2 , DSQRT

      REAL(8) :: R1 , R2
C
      R1 = COMP(1)
      IF(DABS(R1) <= SMALLNUM)R1 = 0.D0
      R2 = COMP(2)
      IF(DABS(R2) <= SMALLNUM)R2 = 0.D0
C
      XMOD  = DSQRT(R1*R1 + R2*R2)
C
      IF( DABS(R1) > SMALLNUM .AND. DABS(R2) > SMALLNUM )THEN
        ANGL = DATAN2(R2,R1)
      ELSE IF( DABS(R1) > SMALLNUM .AND. DABS(R2) < SMALLNUM )THEN
        IF( R1 > 0 )THEN
          ANGL = 0.D0
        ELSE
          ANGL = PI
        END IF
      ELSE IF( DABS(R1) < SMALLNUM .AND. DABS(R2) > SMALLNUM )THEN
        IF( R2 > 0 )THEN
          ANGL = PI * 0.5
        ELSE
          ANGL = PI * 1.5
        END IF
      ELSE
        ANGL = 0.D0
      END IF
C
      RETURN
C
      END


SUBROUTINE vmdpl(dee,stress,pl)
!
! This subroutine forms the plastic stress/strain matrix
! for a von-Mises material.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::stress(:),dee(:,:)
 REAL(iwp),INTENT(OUT)::pl(:,:)
 REAL(iwp),ALLOCATABLE::dfds(:),ddfds(:)
 REAL(iwp)::t2,t6,t10,t14,t16,t17,t18,t19,t21,t22,t23,t25,t26,t30,sq2,sx, &
   sy,sz,txy,tyz,tzx,one=1.0_iwp,two=2.0_iwp,d4=4.0_iwp,d6=6.0_iwp
 REAL(iwp)::denom
 INTEGER::i,j,ih
 ih=SIZE(stress)
 ALLOCATE(dfds(ih),ddfds(ih))
 sq2=SQRT(two)
 SELECT CASE(ih)
 CASE(4)
   sx=stress(1)
   sy=stress(2)
   txy=stress(3)
   sz=stress(4)
   t2=sx**2
   t6=sy**2
   t10=sz**2
   t14=txy**2
   t17=SQRT(two*t2-two*sx*sy+two*t6-two*sy*sz+two*t10-two*sz*sx+d6*t14)
   t19=one/sq2/t17
   t21=two*sy
   t22=two*sz
   t26=two*sx
   dfds(1)=t19*(d4*sx-t21-t22)/two
   dfds(2)=t19*(-t26+d4*sy-t22)/two
   dfds(3)=t19*d6*txy
   dfds(4)=t19*(-t21+d4*sz-t26)/two
 CASE(6)
   sx=stress(1)
   sy=stress(2)
   sz=stress(3)
   txy=stress(4)
   tyz=stress(5)
   tzx=stress(6)
   t2=sx**2
   t6=sy**2
   t10=sz**2
   t14=txy**2
   t16=tyz**2
   t18=tzx**2
   t21=SQRT(two*t2-two*sx*sy+two*t6-two*sy*sz+two*t10-                    &
     two*sz*sx+d6*t14+d6*t16+d6*t18)
   t23=one/sq2/t21
   t25=two*sy
   t26=two*sz
   t30=two*sx
   dfds(1)=t23*(d4*sx-t25-t26)/two
   dfds(2)=t23*(-t30+d4*sy-t26)/two
   dfds(3)=t23*(-t25+d4*sz-t30)/two
   dfds(4)=t23*d6*txy
   dfds(5)=t23*d6*tyz
   dfds(6)=t23*d6*tzx
 END SELECT
 ddfds=MATMUL(dee,dfds)
 denom=DOT_PRODUCT(ddfds,dfds)
 DO i=1,ih
   DO j=1,ih
     pl(i,j)=ddfds(i)*ddfds(j)/denom
   END DO
 END DO
 DEALLOCATE(dfds,ddfds)
RETURN
END SUBROUTINE vmdpl


program odd_number
  implicit none
  integer :: N, k
! odd integers between 0 & N
  PRINT*, 'Enter an integer N'
  READ(*,*) N
  WRITE(*,*) 'Odd number between 0 and ', N
  k = 0
  DO
    k = k + 1
    if (k > N) EXIT
    if (mod(k,2) .eq. 0) CYCLE
    WRITE(*,*) k, ' is an odd number between 0 and ', N
  END DO
end program odd_number


	SUBROUTINE ludcmp_dp(a,indx,d)
	USE nrtype; USE Debug_module ; USE nrutil2; USE nrutil, ONLY : assert_eq,imaxloc,nrerror,outerprod,swap
	IMPLICIT NONE
	REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: a
	INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: indx
	REAL(DP), INTENT(OUT) :: d
	REAL(DP), DIMENSION(size(a,1)) :: vv
	REAL(DP), PARAMETER :: TINY=1.0e-20_sp
	INTEGER(I4B) :: j,n,imax
	n=assert_eq(size(a,1),size(a,2),size(indx),'ludcmp')
	d=1.0
	vv=maxval(abs(a),dim=2)
	if (any(vv == 0.0)) then
 Debug_errorflags(flag_ludcmp)=1
   return
   end if
	vv=1.0_sp/vv

	do j=1,n
		imax=(j-1)+imaxloc_dp(vv(j:n)*abs(a(j:n,j)))
		if (j /= imax) then
			call swap_dp(a(imax,:),a(j,:))
			d=-d
			vv(imax)=vv(j)
		end if
		indx(j)=imax
		if (a(j,j) == 0.0) a(j,j)=TINY
		a(j+1:n,j)=a(j+1:n,j)/a(j,j)
		a(j+1:n,j+1:n)=a(j+1:n,j+1:n)-outerprod(a(j+1:n,j),a(j,j+1:n))
	end do
	END SUBROUTINE ludcmp_dp


	FUNCTION PR_HMTR ( tmpf, dwpf )
C************************************************************************
C* PR_HMTR								*
C*									*
C* This function computes HMTR, the humiture index, from TMPF and DWPF, *
C* The output will be calculated in Fahrenheit  The following equation 	*
C* is used:						                *
C*									*
C*		PR_HMTR = TMPF + ( PR_VAPR ( DWPC ) - 21 )		*
C*									*
C* REAL PR_HMTR  ( TMPF, DWPF ) 					*
C*									*
C* Input parameters:							*
C*	TMPF		REAL    	Air temperature 		*
C*	DWPF		REAL		Dewpoint temperature		*
C*									*
C* Output parameters:							*
C*	PR_HMTR		REAL		Humiture Index			*
C**									*
C* Log:									*
C* M. Nelson		 7/92		From Winterling,		*
C*					  BAMS Apr 1979, p 329		*
C* S. Jacobs/EAI	 3/93		Cleaned up			*
C************************************************************************
        INCLUDE  'GEMPRM.PRM'
        INCLUDE  'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ( ERMISS (tmpf) ) .or. ( ERMISS (dwpf) ) )  THEN
	    PR_HMTR = RMISSD
	ELSE
	    dwpc    = PR_TMFC ( dwpf )
	    PR_HMTR = tmpf + ( PR_VAPR ( dwpc ) - 21 )
	END IF
C*
	RETURN
	END


program eratosthenes
   use sieve
   implicit none
   ! variable declarations
   integer, parameter :: LIMIT = 1000
   integer :: n, cnt, siz
   integer, dimension(LIMIT) :: parr
   real:: t1, t2
   ! processing
   print *, 'n'
   read *, n
   if (n .lt. 1) stop

   !if (n <= LIMIT) call pp(n)

   if (npub(n) <= LIMIT) then
      print *, 'simple sieve'
      call smsv(n, parr, cnt)
      if (cnt <= LIMIT) print '(6i12)', parr(:cnt)
      print *, cnt

      print *, 'segmented sieve'
      call sgsv(n, parr, cnt)
      if (cnt <= LIMIT) print '(6i12)', parr(:cnt)
      print *, cnt
   end if

   if (n <= LIMIT) then
      print *, 'first', n, ' prime nos.'
      parr = np(n)
      print '(6i12)', parr(:n)
   end if

   print *, 'sieve size =', nthpub(n)
   print *, 'base primes size =', npub(nthpub(n))
   call cpu_time(t1)
   cnt = nthp(n)
   call cpu_time(t2)
   print *, 'prime no.', n, ' =', cnt
   print *, 'elapsed time = ', t2 - t1, ' seconds'

   call cpu_time(t1)
   call gaps()
   call cpu_time(t2)
   print *, 'elapsed time = ', t2 - t1, ' seconds'
end program eratosthenes


SUBROUTINE tides_solid2(mjd, ut1_utc , dCnm,dSnm)

! ----------------------------------------------------------------------
! SUBROUTINE: tides_solid2.f90
! ----------------------------------------------------------------------
! Purpose:
! Solid Earth Tides (frequency dependent)
!  Solid Earth Tides (Step 2) based on IERS Conventions 2010.
!  tides_solid2 implements the Step2 that refers to the computation of the
!  frequency dependent corrections to the geopotential's spherical harmonic
!  coefficients.
! ----------------------------------------------------------------------
! Input arguments
! - mjd:			MJD in Terrestrial Time (TT) scale including the fraction
!             		of the day
! - ut1_utc:   		Time difference between UT1 and UTC (seconds)
!					See Remark 3
!
! Output arguments:
! - dCnm :			Cnm corrections matrix
! - dSnm :			Snm corrections matrix
! ----------------------------------------------------------------------
! Remark 1:
!  Computed dCnm and dSnm are formed into lower triangular matrices.
!  Coefficient dCnm corresponds to the matrix element dCnm(n+1,m+1).
!
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	9 November 2015
! ----------------------------------------------------------------------
! Last modified:
! - Dr. Thomas Papanikolaou, 27 October 2017:
!   The subroutine has been modified in order to call the subroutine gmst_iers.f03
!   for the computation of the Greenwich mean sidereal time
! - Dr. Thomas Papanikolaou, 30 January 2019:
!   Modified in order to replace the fundamental arguments used in the
!   basic formula of the tidal corrections.
!   The Doodson arguments and multipliers are now applied instead of the Delaunay arguments.
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN) :: mjd, ut1_utc

! OUT
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(3,3) :: dCnm, dSnm
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q) :: thetag, thetaf
      REAL (KIND = prec_q) :: F1,F2,F3,F4,F5
      REAL (KIND = prec_d), DIMENSION(5) :: delaunay_arr
      REAL (KIND = prec_q) :: beta1, beta2, beta3, beta4, beta5, beta6
      REAL (KIND = prec_d), DIMENSION(6) :: doodson_arr
      REAL (KIND = prec_d) :: table65b(21,9) , table65b_transp(9,21)
      REAL (KIND = prec_d) :: table65a(48,9) , table65a_transp(9,48)
      REAL (KIND = prec_d), DIMENSION(2,8) :: table65c
      INTEGER (KIND = prec_int2) :: sz1, sz2, i, j
      REAL (KIND = prec_q) :: dC20, dC21,dS21, dC22,dS22
      REAL (KIND = prec_q) :: matrix_mult
      REAL (KIND = prec_q) :: pi
! ----------------------------------------------------------------------

dCnm = 0.0D0
dCnm = 0.0D0
pi = PI_global

! ----------------------------------------------------------------------
! Delaunay variables (in radians)
CALL delaunay (mjd , F1,F2,F3,F4,F5)
delaunay_arr = (/ F1 , F2 , F3 , F4 , F5 /)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Greenwich Mean Sidereal Time (GMST) in radians
Call gmst_iers(mjd, ut1_utc , thetag)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Doodson arguments in radians
! ----------------------------------------------------------------------
! N' = -Omega : Negative of the Mean Longitude of the Ascending Node of the Moon
beta5 = -1.0D0 * F5
! s = F+Omega : Mean Longitude of the Moon
beta2 = F3 + F5
! taph = thetag+p - s : Mean Lunar Time
beta1 = (thetag + pi) -1.0D0 * beta2
! h = s - D : Mean Longitude of the Sun
beta3 = beta2 - F4
! p = s - l : Longitude of the Moon's mean perigee
beta4 = beta2 - F1
! ps = s - D - l' : Longitude of the Sun's mean perigee
beta6 = beta2 - F4 -F2

doodson_arr = (/ beta1 , beta2 , beta3 , beta4 , beta5, beta6 /)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! dC20 correction
! Table 6.5b
! Columns : Doodson_No. Doodson arguments multipliers (Coll.2-7)  Amp.(ip) Amp.(op)
table65b_transp  = RESHAPE ( (/                                      &
55.565D0,  0.0D0,  0.0D0,  0.0D0,  0.0D0,  1.0D0,  0.0D0,  16.6D0,  -6.7D0,  &
55.575D0,  0.0D0,  0.0D0,  0.0D0,  0.0D0,  2.0D0,  0.0D0,  -0.1D0,   0.1D0,  &
56.554D0,  0.0D0,  0.0D0,  1.0D0,  0.0D0,  0.0D0, -1.0D0,  -1.2D0,   0.8D0,  &
57.555D0,  0.0D0,  0.0D0,  2.0D0,  0.0D0,  0.0D0,  0.0D0,  -5.5D0,   4.3D0,  &
57.565D0,  0.0D0,  0.0D0,  2.0D0,  0.0D0,  1.0D0,  0.0D0,   0.1D0,  -0.1D0,  &
58.554D0,  0.0D0,  0.0D0,  3.0D0,  0.0D0,  0.0D0, -1.0D0,  -0.3D0,   0.2D0,  &
63.655D0,  0.0D0,  1.0D0, -2.0D0,  1.0D0,  0.0D0,  0.0D0,  -0.3D0,   0.7D0,  &
65.445D0,  0.0D0,  1.0D0,  0.0D0, -1.0D0, -1.0D0,  0.0D0,   0.1D0,  -0.2D0,  &
65.455D0,  0.0D0,  1.0D0,  0.0D0, -1.0D0,  0.0D0,  0.0D0,  -1.2D0,   3.7D0,  &
65.465D0,  0.0D0,  1.0D0,  0.0D0, -1.0D0,  1.0D0,  0.0D0,   0.1D0,  -0.2D0,  &
65.655D0,  0.0D0,  1.0D0,  0.0D0,  1.0D0,  0.0D0,  0.0D0,   0.1D0,  -0.2D0,  &
73.555D0,  0.0D0,  2.0D0, -2.0D0,  0.0D0,  0.0D0,  0.0D0,   0.0D0,   0.6D0,  &
75.355D0,  0.0D0,  2.0D0,  0.0D0, -2.0D0,  0.0D0,  0.0D0,   0.0D0,   0.3D0,  &
75.555D0,  0.0D0,  2.0D0,  0.0D0,  0.0D0,  0.0D0,  0.0D0,   0.6D0,   6.3D0,  &
75.565D0,  0.0D0,  2.0D0,  0.0D0,  0.0D0,  1.0D0,  0.0D0,   0.2D0,   2.6D0,  &
75.575D0,  0.0D0,  2.0D0,  0.0D0,  0.0D0,  2.0D0,  0.0D0,   0.0D0,   0.2D0,  &
83.655D0,  0.0D0,  3.0D0, -2.0D0,  1.0D0,  0.0D0,  0.0D0,   0.1D0,   0.2D0,  &
85.455D0,  0.0D0,  3.0D0,  0.0D0, -1.0D0,  0.0D0,  0.0D0,   0.4D0,   1.1D0,  &
85.465D0,  0.0D0,  3.0D0,  0.0D0, -1.0D0,  1.0D0,  0.0D0,   0.2D0,   0.5D0,  &
93.555D0,  0.0D0,  4.0D0, -2.0D0,  0.0D0,  0.0D0,  0.0D0,   0.1D0,   0.2D0,  &
95.355D0,  0.0D0,  4.0D0,  0.0D0, -2.0D0,  0.0D0,  0.0D0,   0.1D0,   0.1D0  /) , (/ 9 , 21 /) )

table65b = TRANSPOSE (table65b_transp)

! dC20 computation
sz1 = SIZE (table65b,DIM=1)
sz2 = SIZE (table65b,DIM=2)
!PRINT *,"sz1",sz1

dC20 = 0.0D0
DO i = 1 , sz1
    ! thetaf (in radians)
      matrix_mult = 0.0D0
      DO j = 1 , 6
	     matrix_mult = matrix_mult + ( table65b(i,j+1) * doodson_arr(j) )
      END DO
    !thetaf = -1.0D0 * matrix_mult
    thetaf = matrix_mult

    dC20 = dC20 + table65b(i,8) * 1.0D-12 * cos(thetaf) - table65b(i,9) * 1.0D-12 * sin(thetaf)
END DO
dCnm(2+1,0+1) = dC20
!PRINT *,"dC20",dC20
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! dC21,dS21 corrections
! Table 6.5a
! Columns : Doodson_No. Doodson arguments multipliers (Coll.2-7)  Amp.(ip) Amp.(op)
table65a_transp  = RESHAPE ( (/                                         &
125.755D0,  1.0D0, -3.0D0,  0.0D0,  2.0D0,  0.0D0,  0.0D0,   -0.1D0,    0.0D0,  &
127.555D0,  1.0D0, -3.0D0,  2.0D0,  0.0D0,  0.0D0,  0.0D0,   -0.1D0,    0.0D0,  &
135.645D0,  1.0D0, -2.0D0,  0.0D0,  1.0D0, -1.0D0,  0.0D0,   -0.1D0,    0.0D0,  &
135.655D0,  1.0D0, -2.0D0,  0.0D0,  1.0D0,  0.0D0,  0.0D0,   -0.7D0,    0.1D0,  &
137.455D0,  1.0D0, -2.0D0,  2.0D0, -1.0D0,  0.0D0,  0.0D0,   -0.1D0,    0.0D0,  &
145.545D0,  1.0D0, -1.0D0,  0.0D0,  0.0D0, -1.0D0,  0.0D0,   -1.3D0,    0.1D0,  &
145.555D0,  1.0D0, -1.0D0,  0.0D0,  0.0D0,  0.0D0,  0.0D0,   -6.8D0,    0.6D0,  &
147.555D0,  1.0D0, -1.0D0,  2.0D0,  0.0D0,  0.0D0,  0.0D0,    0.1D0,    0.0D0,  &
153.655D0,  1.0D0,  0.0D0, -2.0D0,  1.0D0,  0.0D0,  0.0D0,    0.1D0,    0.0D0,  &
155.445D0,  1.0D0,  0.0D0,  0.0D0, -1.0D0, -1.0D0,  0.0D0,    0.1D0,    0.0D0,  &
155.455D0,  1.0D0,  0.0D0,  0.0D0, -1.0D0,  0.0D0,  0.0D0,    0.4D0,    0.0D0,  &
155.655D0,  1.0D0,  0.0D0,  0.0D0,  1.0D0,  0.0D0,  0.0D0,    1.3D0,   -0.1D0,  &
155.665D0,  1.0D0,  0.0D0,  0.0D0,  1.0D0,  1.0D0,  0.0D0,    0.3D0,    0.0D0,  &
157.455D0,  1.0D0,  0.0D0,  2.0D0, -1.0D0,  0.0D0,  0.0D0,    0.3D0,    0.0D0,  &
157.465D0,  1.0D0,  0.0D0,  2.0D0, -1.0D0,  1.0D0,  0.0D0,    0.1D0,    0.0D0,  &
162.556D0,  1.0D0,  1.0D0, -3.0D0,  0.0D0,  0.0D0,  1.0D0,   -1.9D0,    0.1D0,  &
163.545D0,  1.0D0,  1.0D0, -2.0D0,  0.0D0, -1.0D0,  0.0D0,    0.5D0,    0.0D0,  &
163.555D0,  1.0D0,  1.0D0, -2.0D0,  0.0D0,  0.0D0,  0.0D0,  -43.4D0,    2.9D0,  &
164.554D0,  1.0D0,  1.0D0, -1.0D0,  0.0D0,  0.0D0, -1.0D0,    0.6D0,    0.0D0,  &
164.556D0,  1.0D0,  1.0D0, -1.0D0,  0.0D0,  0.0D0,  1.0D0,    1.6D0,   -0.1D0,  &
165.345D0,  1.0D0,  1.0D0,  0.0D0, -2.0D0, -1.0D0,  0.0D0,    0.1D0,    0.0D0,  &
165.535D0,  1.0D0,  1.0D0,  0.0D0,  0.0D0, -2.0D0,  0.0D0,    0.1D0,    0.0D0,  &
165.545D0,  1.0D0,  1.0D0,  0.0D0,  0.0D0, -1.0D0,  0.0D0,   -8.8D0,    0.5D0,  &
165.555D0,  1.0D0,  1.0D0,  0.0D0,  0.0D0,  0.0D0,  0.0D0,  470.9D0,  -30.2D0,  &
165.565D0,  1.0D0,  1.0D0,  0.0D0,  0.0D0,  1.0D0,  0.0D0,   68.1D0,   -4.6D0,  &
165.575D0,  1.0D0,  1.0D0,  0.0D0,  0.0D0,  2.0D0,  0.0D0,   -1.6D0,    0.1D0,  &
166.455D0,  1.0D0,  1.0D0,  1.0D0, -1.0D0,  0.0D0,  0.0D0,    0.1D0,    0.0D0,  &
166.544D0,  1.0D0,  1.0D0,  1.0D0,  0.0D0, -1.0D0, -1.0D0,   -0.1D0,    0.0D0,  &
166.554D0,  1.0D0,  1.0D0,  1.0D0,  0.0D0,  0.0D0, -1.0D0,  -20.6D0,   -0.3D0,  &
166.556D0,  1.0D0,  1.0D0,  1.0D0,  0.0D0,  0.0D0,  1.0D0,    0.3D0,    0.0D0,  &
166.564D0,  1.0D0,  1.0D0,  1.0D0,  0.0D0,  1.0D0, -1.0D0,   -0.3D0,    0.0D0,  &
167.355D0,  1.0D0,  1.0D0,  2.0D0, -2.0D0,  0.0D0,  0.0D0,   -0.2D0,    0.0D0,  &
167.365D0,  1.0D0,  1.0D0,  2.0D0, -2.0D0,  1.0D0,  0.0D0,   -0.1D0,    0.0D0,  &
167.555D0,  1.0D0,  1.0D0,  2.0D0,  0.0D0,  0.0D0,  0.0D0,   -5.0D0,    0.3D0,  &
167.565D0,  1.0D0,  1.0D0,  2.0D0,  0.0D0,  1.0D0,  0.0D0,    0.2D0,    0.0D0,  &
168.554D0,  1.0D0,  1.0D0,  3.0D0,  0.0D0,  0.0D0, -1.0D0,   -0.2D0,    0.0D0,  &
173.655D0,  1.0D0,  2.0D0, -2.0D0,  1.0D0,  0.0D0,  0.0D0,   -0.5D0,    0.0D0,  &
173.665D0,  1.0D0,  2.0D0, -2.0D0,  1.0D0,  1.0D0,  0.0D0,   -0.1D0,    0.0D0,  &
175.445D0,  1.0D0,  2.0D0,  0.0D0, -1.0D0, -1.0D0,  0.0D0,    0.1D0,    0.0D0,  &
175.455D0,  1.0D0,  2.0D0,  0.0D0, -1.0D0,  0.0D0,  0.0D0,   -2.1D0,    0.1D0,  &
175.465D0,  1.0D0,  2.0D0,  0.0D0, -1.0D0,  1.0D0,  0.0D0,   -0.4D0,    0.0D0,  &
183.555D0,  1.0D0,  3.0D0, -2.0D0,  0.0D0,  0.0D0,  0.0D0,   -0.2D0,    0.0D0,  &
185.355D0,  1.0D0,  3.0D0,  0.0D0, -2.0D0,  0.0D0,  0.0D0,   -0.1D0,    0.0D0,  &
185.555D0,  1.0D0,  3.0D0,  0.0D0,  0.0D0,  0.0D0,  0.0D0,   -0.6D0,    0.0D0,  &
185.565D0,  1.0D0,  3.0D0,  0.0D0,  0.0D0,  1.0D0,  0.0D0,   -0.4D0,    0.0D0,  &
185.575D0,  1.0D0,  3.0D0,  0.0D0,  0.0D0,  2.0D0,  0.0D0,   -0.1D0,    0.0D0,  &
195.455D0,  1.0D0,  4.0D0,  0.0D0, -1.0D0,  0.0D0,  0.0D0,   -0.1D0,    0.0D0,  &
195.465D0,  1.0D0,  4.0D0,  0.0D0, -1.0D0,  1.0D0,  0.0D0,   -0.1D0,    0.0D0   &
/) , (/ 9 , 48 /) )

table65a = TRANSPOSE (table65a_transp)

! dC21 dS21 computations
sz1 = SIZE (table65a,DIM=1)
sz2 = SIZE (table65a,DIM=2)
!PRINT *,"sz1", sz1

dC21 = 0.0D0
dS21 = 0.0D0
DO i = 1 , sz1
    ! thetaf (in radians)
      matrix_mult = 0.0D0
      DO j = 1 , 6
	     matrix_mult = matrix_mult + ( table65a(i,j+1) * doodson_arr(j) )
      END DO
      !thetaf = 1.0D0 * (thetag + pi) -1.0D0 * matrix_mult
      thetaf = matrix_mult
    dC21 = dC21 + table65a(i,8) * 1.0D-12 * sin(thetaf) + table65a(i,9) * 1.0D-12 * cos(thetaf)
    dS21 = dS21 + table65a(i,8) * 1.0D-12 * cos(thetaf) - table65a(i,9) * 1.0D-12 * sin(thetaf)
END DO
dCnm(2+1,1+1) = dC21
dSnm(2+1,1+1) = dS21
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! dC22,dS22 corrections
! Table 6.5c
! Columns :  Doodson_No. Doodson arguments multipliers (2-7) Amp.
table65c(1,1:8) = (/ 245.655D0,  2.0D0, -1.0D0,  0.0D0,  1.0D0,  0.0D0,  0.0D0,   -0.3D0 /)
table65c(2,1:8) = (/ 255.555D0,  2.0D0,  0.0D0,  0.0D0,  0.0D0,  0.0D0,  0.0D0,   -1.2D0 /)

! dC22 dS22 computations
dC22 = 0.0D0
dS22 = 0.0D0
      DO i = 1 , 2
         ! thetaf (in radians)
         matrix_mult = 0.0D0
         DO j = 1 , 6
	        matrix_mult = matrix_mult + ( table65c(i,j+1) * doodson_arr(j) )
         END DO
         !thetaf = 2.0D0 * (thetag + pi) -1.0D0 * matrix_mult
         thetaf = matrix_mult
         dC22 = dC22 + table65c(i,8) * 1.0D-12 * cos(thetaf) ! -1.0D * table65c(i,8) * 1.0D-12 * sin(thetaf)
         dS22 = dS22 - table65c(i,8) * 1.0D-12 * sin(thetaf) ! -1.0D * table65c(i,8) * 1.0D-12 * cos(thetaf)
      END DO
dCnm(2+1,2+1) = dC22
dSnm(2+1,2+1) = dS22

END


program Hamming_Test
  use big_integer_module
  implicit none

  call Hamming(1,20)
  write(*,*)
  call Hamming(1691)
  write(*,*)
  call Hamming(1000000)

contains

subroutine Hamming(first, last)

  integer, intent(in) :: first
  integer, intent(in), optional :: last
  integer :: i, n, i2, i3, i5, lim
  type(big_integer), allocatable :: hnums(:)

  if(present(last)) then
    lim = last
  else
    lim = first
  end if

  if(first < 1 .or. lim > 2500000 ) then
    write(*,*) "Invalid input"
    return
  end if

  allocate(hnums(lim))

  i2 = 1 ;  i3 = 1 ; i5 = 1
  hnums(1) = 1
  n = 1
  do while(n < lim)
    n = n + 1
    hnums(n) = mini(2*hnums(i2), 3*hnums(i3), 5*hnums(i5))
    if(2*hnums(i2) == hnums(n)) i2 = i2 + 1
    if(3*hnums(i3) == hnums(n)) i3 = i3 + 1
    if(5*hnums(i5) == hnums(n)) i5 = i5 + 1
  end do

  if(present(last)) then
    do i = first, last
      call print_big(hnums(i))
      write(*, "(a)", advance="no") " "
    end do
  else
    call print_big(hnums(first))
  end if

  deallocate(hnums)
end subroutine

function mini(a, b, c)
  type(big_integer) :: mini
  type(big_integer), intent(in) :: a, b, c

  if(a < b ) then
    if(a < c) then
      mini = a
    else
      mini = c
    end if
  else if(b < c) then
    mini = b
  else
    mini = c
  end if
end function mini
end program


!http://www.nersc.gov/users/software/programming-libraries/math-libraries/fftw/fftw3-serial-1d-example-fortran-source/
implicit none
      include "fftw3.f"

      integer n
      parameter (n=16)

      integer*8 plan, iplan

      double complex in, out
      dimension in(N), out(N)

      integer i

      print *,"n = ",n
      print *,"input = "
      do i=1,n
         in(i) = (1.0, 0.0)
         print *,in(i)
      enddo

      print *,"fftw_fwd =      ",fftw_forward
      print *,"fftw_bkwd =     ",fftw_backward
      print *,"fftw_estimate = ",fftw_estimate

      call dfftw_plan_dft_1d(plan, n,in,out,fftw_forward, FFTW_ESTIMATE)
      call dfftw_plan_dft_1d(iplan,n,out,in,fftw_backward,FFTW_ESTIMATE)

      print *,"address of fwd plan =   ",plan
      print *,"address of bckwd plan = ",iplan

      call dfftw_execute(plan)

      print *, 'output after forward fft:'
      do i=1,n
         print *, out(i)
      enddo

      call dfftw_execute(iplan)

      print *, 'after inverse fft:'
      do i=1,n
         print *, in(i)
      enddo

      call dfftw_destroy_plan(plan)
      call dfftw_destroy_plan(iplan)

      end


module parameters

! b8 will be used to define reals with 14 digits
integer,  parameter :: b8 = selected_real_kind(14)

!!! REAL UNIT PARAMETERS !!!
real(b8), parameter ::  rReal =     5.0_b8   ! in microns
real(b8), parameter ::  bReal =     1.0_b8   ! in microns
real(b8), parameter ::  lReal =    60.0_b8   ! in microns
real(b8), parameter :: syReal =    60.0_b8   ! in microns
real(b8), parameter :: szReal =    60.0_b8   ! in microns
real(b8), parameter ::  dReal =    20.0_b8   ! in microns^2/s
real(b8), parameter ::  kReal =    50.0_b8   ! in 1/s
real(b8), parameter ::  hReal =     5.0_b8   ! in microns

end module

!!! PARAMETER DESCRIPTIONS !!!
!
!  All length parameters are in units of microns.
!  All time parameters are in units of seconds.
!
!  rReal = cell radius
!  bReal = particle jump distance
!  lReal = system length in gradient direction
! syReal = system length perpendicular to gradient
! szReal = system length perpendicular to gradient
!      s = syReal * szReal; the area of the surface where particles are produced
!  dReal = diffusion coefficient
!  kReal = particle production rate
!
!  hReal = cell height, only used for 2D configuration. Cells are discs with
!          hReal and radius rReal
!
!!! PARAMETER DESCRIPTIONS !!!


double precision function true_solution(x, y, t)
    double precision :: x, y, t
    true_solution = exp(-2*t) * sin(x) * sin(y)
end function true_solution


MODULE dspline

IMPLICIT NONE

! Use predictor-corrector schemes based on difference splines

CONTAINS

  SUBROUTINE point_to_Taylor(x,y,c,x0,m)
!
! Compute the coefficients in Taylor form centered at x0
! of the interpolant of the data y at the nodes x
!
  INTEGER, INTENT(IN) :: m  ! The degree
  DOUBLE PRECISION, DIMENSION(0:m), INTENT(IN) :: x,y
  DOUBLE PRECISION, DIMENSION(0:m), INTENT(OUT) :: c
  DOUBLE PRECISION, INTENT(IN) :: x0
!
  DOUBLE PRECISION, DIMENSION(0:m) :: dx,newton
  INTEGER :: j,k
!
! Compute the Newton polynomial
!
  dx=x-x0
  newton=y
  DO k=1,m
    DO j=0,m-k
      newton(j)=(newton(j+1)-newton(j))/(dx(j+k)-dx(j))
    END DO
  END DO
!
! Now change from Newton to Taylor
!
  c=0.d0
  c(0)=newton(0)
  DO k=1,m
    DO j=k,1,-1
      c(j)=c(j-1)-dx(k)*c(j)
    END DO
    c(0)=newton(k)-dx(k)*c(0)
  END DO
!
  END SUBROUTINE point_to_Taylor

  SUBROUTINE Hermite(cl,xl,cr,xr,ch,x0,m)
!
! Compute the Hermite interpolant of the degree m Taylor polynomials
! centered at xl,xr and express as a degree 2m+1 Taylor polynomial
! centered at x0
!
  INTEGER, INTENT(IN) :: m
  DOUBLE PRECISION, INTENT(IN) :: xl,xr,x0
  DOUBLE PRECISION, DIMENSION(0:m), INTENT(IN) :: cl,cr
  DOUBLE PRECISION, DIMENSION(0:2*m+1), INTENT(OUT) :: ch
!
  DOUBLE PRECISION, DIMENSION(0:2*m+1) :: dx,Newton
  INTEGER :: j,k
!
  dx(0:m)=xl-x0
  dx(m+1:2*m+1)=xr-x0
  Newton(0:m)=cl(0)
  Newton(m+1:2*m+1)=cr(0)
!
  DO k=1,2*m+1
    IF (k <= m) THEN
      DO j=0,m-k
        Newton(j)=cl(k)
      END DO
      DO j=m-k+1,m
        Newton(j)=(Newton(j+1)-Newton(j))/(dx(j+k)-dx(j))
      END DO
      DO j=m+1,2*m+1-k
        Newton(j)=cr(k)
      END DO
    ELSE
      DO j=0,2*m+1-k
        Newton(j)=(Newton(j+1)-Newton(j))/(dx(j+k)-dx(j))
      END DO
    END IF
  END DO
!
! Now change from Newton to Taylor
!
  ch=0.d0
  ch(0)=Newton(0)
  DO k=1,2*m+1
    DO j=k,1,-1
      ch(j)=ch(j-1)-dx(k)*ch(j)
    END DO
    ch(0)=Newton(k)-dx(k)*ch(0)
  END DO
!
  END SUBROUTINE Hermite

!
  SUBROUTINE point_to_dspline(x,y,c,xl,xr,m,n)
!
! Compute the coefficients of the degree 2m+1 dspline on [xl,xr]
!
! The result is in Taylor form centered at (xl+xr)/2
!
! Assume data for xl starts at x(0) and for xr ends at x(n)
!
  INTEGER, INTENT(IN) :: m,n
  DOUBLE PRECISION, DIMENSION(0:n), INTENT(IN) :: x,y
  DOUBLE PRECISION, DIMENSION(0:2*m+1), INTENT(OUT) :: c
  DOUBLE PRECISION, INTENT(IN) :: xl,xr
!
  DOUBLE PRECISION, DIMENSION(0:m) :: yl,xxl,yr,xxr,cl,cr
  DOUBLE PRECISION :: x0
  INTEGER :: j
!
! Check for enough data
!
  IF (n < m) THEN
    PRINT *,'Not enough data in point_to_dspline'
    STOP
  END IF
!
  yl=y(0:m)
  xxl=x(0:m)
  yr=y(n-m:n)
  xxr=x(n-m:n)
  x0=(xl+xr)/2.d0
!
  CALL point_to_Taylor(xxl,yl,cl,xl,m)
  CALL point_to_Taylor(xxr,yr,cr,xr,m)
  CALL Hermite(cl,xl,cr,xr,c,x0,m)
!
  END SUBROUTINE point_to_dspline

  SUBROUTINE Interp(tnow,t,dt,uev,upev,u,m,n)
!
  INTEGER, INTENT(IN) :: m,n
  DOUBLE PRECISION, INTENT(IN) :: tnow,t,dt
  DOUBLE PRECISION, DIMENSION(n), INTENT(IN) :: u
  DOUBLE PRECISION, INTENT(OUT) :: uev,upev
!
! tnow - current time
! t    - desired time <= tnow
! dt   - time step
! u    - data u(j)=u at time tnow-(n-j)*dt
! n    - dimension of u Must have t >= tnow-(n-2)*dt
! m    - degree 2m+1 spline
! uev,upev - dspline interpolant and derivative evaluated at t
!
  INTEGER :: k,nh,jr,nr
  DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: x,y
  DOUBLE PRECISION, DIMENSION(0:2*m+1) :: c
  DOUBLE PRECISION :: tl,tr,s
!
! Where is t?
!
  jr=INT((tnow-t)/dt)
  tr=tnow-dt*DBLE(jr)
  tl=tr-dt
  s=t-.5d0*(tl+tr)
!
! t is located between n-jr-1 and n-jr
!
! Are we in a regular case or near the present time?
!
  IF ((n-jr+m/2) <= n) THEN
    nh=m+1
    nr=n-jr+m/2
  ELSE
    nh=m
    nr=n
  END IF
  ALLOCATE(x(0:nh),y(0:nh))
  IF ((nr-nh) < 0) THEN
    y(nh-nr:nh)=u(0:nr)
    y(0:nh-nr-1)=0.d0
  ELSE
    y(0:nh)=u(nr-nh:nr)
  END IF
  DO k=0,nh
    x(k)=tnow-dt*DBLE(n-nr+nh-k)
  END DO
  CALL point_to_dspline(x,y,c,tl,tr,m,nh)
  uev=c(2*m+1)
  upev=DBLE(2*m+1)*c(2*m+1)
  DO k=2*m,1,-1
    uev=s*uev+c(k)
    upev=s*upev+DBLE(k)*c(k)
  END DO
  uev=s*uev+c(0)
!
  DEALLOCATE(x,y)
!
  END SUBROUTINE Interp

  SUBROUTINE Extrap(xcof,m)
!
  INTEGER, INTENT(IN) :: m
  DOUBLE PRECISION, DIMENSION(0:m), INTENT(OUT) :: xcof
!
! Return extrapolation coefficients for degree m
!
  INTEGER :: k,j
!
  DO k=0,m
    xcof(k)=1.d0
    DO j=0,m
      IF (j /= k) THEN
        xcof(k)=xcof(k)*DBLE(m+1-j)/DBLE(k-j)
      END IF
    END DO
  END DO
!
  END SUBROUTINE Extrap

  SUBROUTINE Extrapnoalloc(xcof,m)
! Barnett needed version that doesn't allocate, to call from matlab/mex
! 12/22/16
  INTEGER, INTENT(IN) :: m
  DOUBLE PRECISION, DIMENSION(0:m), INTENT(INOUT) :: xcof
!
! Return extrapolation coefficients for degree m
!
  INTEGER :: k,j
!
  DO k=0,m
    xcof(k)=1.d0
    DO j=0,m
      IF (j /= k) THEN
        xcof(k)=xcof(k)*DBLE(m+1-j)/DBLE(k-j)
      END IF
    END DO
  END DO
!
  END SUBROUTINE Extrapnoalloc

  SUBROUTINE InterpMat(r,tinterp,dt,m,jmax,jmin,umat,upmat)
!
  INTEGER, INTENT(IN) :: m,r
  DOUBLE PRECISION, DIMENSION(r), INTENT(IN) :: tinterp
  DOUBLE PRECISION, INTENT(IN) :: dt
  INTEGER, INTENT(OUT) :: jmax,jmin
  DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE, INTENT(OUT) :: umat,upmat
!
! r       - number of interpolation times
! tinterp - desired times assumed negative with the current time =0
! dt      - time step
! m       - degree 2m+1 spline
! jmax    - maximum time index for interpolation data - <= 0 with current time 0
! jmin    - minimum time index for interpolation data - <= 0 with current time 0
! umat    - matrix of dimension r X (jmax-jmin+1) for u interpolation
! upmat   - matrix of dimension r X (jmax-jmin+1) for du/dt interpolation
!
  INTEGER :: jt,mh,j,k,jf,nr,kp,nc
  DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: u_to_cof
  DOUBLE PRECISION, DIMENSION(:,:,:), ALLOCATABLE :: uf_to_cof
  DOUBLE PRECISION, DIMENSION(0:2*m+1) :: c
  DOUBLE PRECISION, DIMENSION(0:m+1) :: x,y
  DOUBLE PRECISION, DIMENSION(0:m) :: xf,yf
  INTEGER, DIMENSION(r) :: jtmax,jtmin
  DOUBLE PRECISION :: tl,tr,s
!  LOGICAL, SAVE :: first_call=.TRUE.
!
  mh=m/2
!
    ALLOCATE(u_to_cof(0:2*m+1,m+2))
    DO k=0,m+1
      x(k)=dt*DBLE(k-mh)
    END DO
    tl=x(mh)
    tr=x(mh+1)
    DO k=0,m+1
      y=0.d0
      y(k)=1.d0
      CALL point_to_dspline(x,y,c,tl,tr,m,m+1)
      DO j=0,2*m+1
        u_to_cof(j,k+1)=c(j)
      END DO
    END DO
!
    ALLOCATE(uf_to_cof(mh,0:2*m+1,m+1))
    DO k=0,m
      xf(k)=dt*DBLE(k-m)
    END DO
    DO jf=1,mh
      tr=dt*DBLE(jf-mh)
      tl=tr-dt
      DO k=0,m
        yf=0.d0
        yf(k)=1.d0
        CALL point_to_dspline(xf,yf,c,tl,tr,m,m)
        DO j=0,2*m+1
          uf_to_cof(jf,j,k+1)=c(j)
        END DO
      END DO
    END DO
!

  DO jt=1,r
!
! Where is t?
!
    nr=INT(tinterp(jt)/dt)
    jtmax(jt)=MIN(0,nr+mh)
    jtmin(jt)=MIN(-m,nr-1-mh)
    IF (jt==1) THEN
      jmax=jtmax(1)
      jmin=jtmin(1)
    END IF
    IF (jtmax(jt) > jmax) THEN
      jmax=jtmax(jt)
    END IF
    IF (jtmin(jt) < jmin) THEN
      jmin=jtmin(jt)
    END IF
!
  END DO
!
  nc=jmax-jmin+1
  ALLOCATE(umat(r,nc),upmat(r,nc))
  umat=0.d0
  upmat=0.d0
!
  DO jt=1,r
    s=tinterp(jt)-dt*(DBLE(INT(tinterp(jt)/dt))-.5d0)
    IF ((jtmax(jt)-jtmin(jt))==(m+1)) THEN
      DO k=1,m+2
        kp=jtmin(jt)-jmin+k
        umat(jt,kp)=u_to_cof(2*m+1,k)
        upmat(jt,kp)=DBLE(2*m+1)*u_to_cof(2*m+1,k)
        DO j=2*m,1,-1
          umat(jt,kp)=s*umat(jt,kp)+u_to_cof(j,k)
          upmat(jt,kp)=s*upmat(jt,kp)+DBLE(j)*u_to_cof(j,k)
        END DO
        umat(jt,kp)=s*umat(jt,kp)+u_to_cof(0,k)
      END DO
    ELSE
      jf=INT(tinterp(jt)/dt)+mh
      DO k=1,m+1
        kp=jtmin(jt)-jmin+k
        umat(jt,kp)=uf_to_cof(jf,2*m+1,k)
        upmat(jt,kp)=DBLE(2*m+1)*uf_to_cof(jf,2*m+1,k)
        DO j=2*m,1,-1
          umat(jt,kp)=s*umat(jt,kp)+uf_to_cof(jf,j,k)
          upmat(jt,kp)=s*upmat(jt,kp)+DBLE(j)*uf_to_cof(jf,j,k)
        END DO
        umat(jt,kp)=s*umat(jt,kp)+uf_to_cof(jf,0,k)
      END DO
    END IF
!
  END DO
!
  END SUBROUTINE InterpMat

! Barnett/MEX needed this f77-style version which assumes outputs allocated:
  SUBROUTINE InterpMatnoalloc(r,tinterp,dt,m,jmax,jmin,umat,upmat,nc)
!
  INTEGER, INTENT(IN) :: m,r,nc
  DOUBLE PRECISION, DIMENSION(r), INTENT(IN) :: tinterp
  DOUBLE PRECISION, INTENT(IN) :: dt
  INTEGER, INTENT(OUT) :: jmax,jmin
  DOUBLE PRECISION, DIMENSION(r,nc), INTENT(INOUT) :: umat,upmat
!
! r       - number of interpolation times
! tinterp - desired times assumed negative with the current time =0
! dt      - time step
! m       - degree 2m+1 spline
! jmax    - maximum time index for interpolation data - <= 0 with current time 0
! jmin    - minimum time index for interpolation data - <= 0 with current time 0
! umat    - matrix of dimension r X (jmax-jmin+1) for u interpolation
! upmat   - matrix of dimension r X (jmax-jmin+1) for du/dt interpolation
!
  INTEGER :: jt,mh,j,k,jf,nr,kp
  DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: u_to_cof
  DOUBLE PRECISION, DIMENSION(:,:,:), ALLOCATABLE :: uf_to_cof
  DOUBLE PRECISION, DIMENSION(0:2*m+1) :: c
  DOUBLE PRECISION, DIMENSION(0:m+1) :: x,y
  DOUBLE PRECISION, DIMENSION(0:m) :: xf,yf
  INTEGER, DIMENSION(r) :: jtmax,jtmin
  DOUBLE PRECISION :: tl,tr,s
!  LOGICAL, SAVE :: first_call=.TRUE.
!
  mh=m/2
!
    ALLOCATE(u_to_cof(0:2*m+1,m+2))
    DO k=0,m+1
      x(k)=dt*DBLE(k-mh)
    END DO
    tl=x(mh)
    tr=x(mh+1)
    DO k=0,m+1
      y=0.d0
      y(k)=1.d0
      CALL point_to_dspline(x,y,c,tl,tr,m,m+1)
      DO j=0,2*m+1
        u_to_cof(j,k+1)=c(j)
      END DO
    END DO
!
    ALLOCATE(uf_to_cof(mh,0:2*m+1,m+1))
    DO k=0,m
      xf(k)=dt*DBLE(k-m)
    END DO
    DO jf=1,mh
      tr=dt*DBLE(jf-mh)
      tl=tr-dt
      DO k=0,m
        yf=0.d0
        yf(k)=1.d0
        CALL point_to_dspline(xf,yf,c,tl,tr,m,m)
        DO j=0,2*m+1
          uf_to_cof(jf,j,k+1)=c(j)
        END DO
      END DO
    END DO
!

  DO jt=1,r
!
! Where is t?
!
    nr=INT(tinterp(jt)/dt)
    jtmax(jt)=MIN(0,nr+mh)
    jtmin(jt)=MIN(-m,nr-1-mh)
    IF (jt==1) THEN
      jmax=jtmax(1)
      jmin=jtmin(1)
    END IF
    IF (jtmax(jt) > jmax) THEN
      jmax=jtmax(jt)
    END IF
    IF (jtmin(jt) < jmin) THEN
      jmin=jtmin(jt)
    END IF
!
  END DO
!
!  nc=jmax-jmin+1
!  ALLOCATE(umat(r,nc),upmat(r,nc))
  umat=0.d0
  upmat=0.d0
!
  DO jt=1,r
    s=tinterp(jt)-dt*(DBLE(INT(tinterp(jt)/dt))-.5d0)
    IF ((jtmax(jt)-jtmin(jt))==(m+1)) THEN
      DO k=1,m+2
        kp=jtmin(jt)-jmin+k
        umat(jt,kp)=u_to_cof(2*m+1,k)
        upmat(jt,kp)=DBLE(2*m+1)*u_to_cof(2*m+1,k)
        DO j=2*m,1,-1
          umat(jt,kp)=s*umat(jt,kp)+u_to_cof(j,k)
          upmat(jt,kp)=s*upmat(jt,kp)+DBLE(j)*u_to_cof(j,k)
        END DO
        umat(jt,kp)=s*umat(jt,kp)+u_to_cof(0,k)
      END DO
    ELSE
      jf=INT(tinterp(jt)/dt)+mh
      DO k=1,m+1
        kp=jtmin(jt)-jmin+k
        umat(jt,kp)=uf_to_cof(jf,2*m+1,k)
        upmat(jt,kp)=DBLE(2*m+1)*uf_to_cof(jf,2*m+1,k)
        DO j=2*m,1,-1
          umat(jt,kp)=s*umat(jt,kp)+uf_to_cof(jf,j,k)
          upmat(jt,kp)=s*upmat(jt,kp)+DBLE(j)*uf_to_cof(jf,j,k)
        END DO
        umat(jt,kp)=s*umat(jt,kp)+uf_to_cof(jf,0,k)
      END DO
    END IF
!
  END DO
!
  END SUBROUTINE InterpMatnoalloc

END MODULE dspline


!!# FUNCTION MODULE: <FUN_xyINTEGRALYY>
MODULE FUN_xyINTEGRALYY

!!## PURPOSE
!! Integrates the function $YY$ over a polygon in 2D.

!*******************************************************************************
!
!! xyINTEGRALYY_Pg integrates the function Y*Y over a polygon in 2D.
!
!  Discussion:
!
!    The polygon is bounded by the points (X(1:N), Y(1:N)).
!
!    INTEGRAL = (1/12) * sum ( 1 <= I <= N )
!      - ( Y(I)**3 + Y(I)**2 * Y(I-1) + Y(I) * Y(I-1)**2 + Y(I-1)**3 )
!      * ( X(I) - X(I-1) )
!
!    where X(0) and Y(0) should be replaced by X(N) and Y(N).
!
!  Modified:
!
!    10 July 2001
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    SF Bockman,
!    Generalizing the Formula for Areas of Polygons to Moments,
!    American Mathematical Society Monthly,
!    1989, pages 131-132.
!
!  Parameters:
!
!    Input, integer N, the number of Pgertices of the polygon.
!    N should be at least 3 for a nonzero INTEGRALYY.
!
!    Input, real ( kind = 8 ) Pg(2,N), the coordinates of the Pgertices
!    of the polygon.  These Pgertices should be giPgen in
!    counter clockwise order.
!
!    Output, real ( kind = 8 ) INTEGRALYY, the Pgalue of the integral.
!

!!## EXTERNAL MODULES
USE FUN_Error                                   !!((04-A-FUN_Error.f90))
USE FUN_xyAVERAGEX                              !!((05-A-FUN_xyAVERAGEX.f90))
USE FUN_xyINTEGRAL1                             !!((06-A-FUN_xyINTEGRAL1.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## PROCEDURE OVERLOADING
INTERFACE xyINTEGRALYY_Pg
 MODULE PROCEDURE xyINTEGRALYY_Pg_Rsp
 MODULE PROCEDURE xyINTEGRALYY_Pg_Rdp
END INTERFACE

!!## PROCEDURE OVERLOADING
!INTERFACE xyINTEGRALYY_Ls
! MODULE PROCEDURE xyINTEGRALYY_Ls_Rsp
! MODULE PROCEDURE xyINTEGRALYY_Ls_Rdp
!END INTERFACE
!
!!!## PUBLIC ACCESS LIST
!PUBLIC :: xyINTEGRALYY_Ls
!PUBLIC :: xyINTEGRALYY_Ls_Rsp
!PUBLIC :: xyINTEGRALYY_Ls_Rdp

!!## PUBLIC ACCESS LIST
PUBLIC :: xyINTEGRALYY_Pg
PUBLIC :: xyINTEGRALYY_Pg_Rsp
PUBLIC :: xyINTEGRALYY_Pg_Rdp

!!## CONTAINED PROCEDURES
CONTAINS

!
!!!### FUNCTION <xyINTEGRALYY_Ls_Rsp>
!FUNCTION xyINTEGRALYY_Ls_Rsp( Ls ) RESULT(INTEGRALX)
!
!!!#### LOCAL MAPPINGS
!USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
!USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))
!INCLUDE "06-A-FUN_xyINTEGRALYY_Ls.f90.hdr"
!!!--begin--
!INCLUDE "06-A-FUN_xyINTEGRALYY_Ls.f90.bdy"
!!!--end--
!END FUNCTION
!
!
!
!!!### FUNCTION <xyINTEGRALYY_Ls_Rdp>
!FUNCTION xyINTEGRALYY_Ls_Rdp( Ls ) RESULT(INTEGRALX)
!
!!!#### LOCAL MAPPINGS
!USE PAR_Constants_Rdp                           !!((02-A-PAR_Constants_Rsp.f90))
!USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))
!INCLUDE "06-A-FUN_xyINTEGRALYY_Ls.f90.hdr"
!!!--begin--
!INCLUDE "06-A-FUN_xyINTEGRALYY_Ls.f90.bdy"
!!!--end--
!END FUNCTION

!!### PURE FUNCTION <xyINTEGRALYY_Pg_Rsp>
PURE FUNCTION xyINTEGRALYY_Pg_Rsp( N , Pg ) RESULT(INTEGRALYY)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rsp                           !!((02-A-PAR_Constants_Rsp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rsp !!((01-A-KND_IntrinsicTypes.f90))

INCLUDE "07-A-FUN_xyINTEGRALYY_Pg.f90.hdr"

!!--begin--
INCLUDE "07-A-FUN_xyINTEGRALYY_Pg.f90.bdy"
!!--end--

END FUNCTION

!!### PURE FUNCTION <xyINTEGRALYY_Pg_Rdp>
PURE FUNCTION xyINTEGRALYY_Pg_Rdp( N , Pg ) RESULT(INTEGRALYY)

!!#### LOCAL MAPPINGS
USE PAR_Constants_Rdp                           !!((02-A-PAR_Constants_Rdp.f90))
USE KND_IntrinsicTypes,ONLY: KIND_R => KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

INCLUDE "07-A-FUN_xyINTEGRALYY_Pg.f90.hdr"
!!--begin--
INCLUDE "07-A-FUN_xyINTEGRALYY_Pg.f90.bdy"

!!--end--
END FUNCTION

END MODULE