SUBROUTINE DiffXuniform2D(var,varX,order,DiffStencilArray,Nx,Ny,alpha)
! By Allan P. Engsig-Karup.
USE Precision
USE DataTypes
IMPLICIT NONE
INTEGER :: Nx, Ny, rank, order, alpha, i,j
REAL(KIND=long), DIMENSION(2*alpha+1,2*alpha+1,2) :: DiffStencilArray
REAL(KIND=long), DIMENSION(Nx,Ny) :: var, varX
REAL(KIND=long), DIMENSION(2*alpha+1) :: Stencil
rank = 2*alpha+1
! one-sided
DO i = 1, alpha
	Stencil = DiffStencilArray(1:rank,i,order)
	DO j = 1, Ny
		varX(i,j) = DOT_PRODUCT(Stencil,var(1:rank,j))
	END DO
END DO
! centered
Stencil = DiffStencilArray(1:rank,alpha+1,order)
DO i = alpha+1, Nx-alpha
	DO j = 1, Ny
		varX(i,j) = DOT_PRODUCT(Stencil,var(i-alpha:i+alpha,j))
	END DO
END DO
! one-sided
DO i = Nx-alpha+1, Nx
	Stencil = DiffStencilArray(1:rank,2*alpha+1-(Nx-i),order)
	DO j = 1, Ny
		varX(i,j) = DOT_PRODUCT(Stencil,var(Nx+1-rank:Nx,j))
	END DO
END DO

END SUBROUTINE DiffXuniform2D


module state_lists
  implicit none
  integer, allocatable :: combination(:,:)
contains

  subroutine get_combination(NOS,NOD)
    integer, intent(in) :: NOS, NOD
    integer :: i, j
    allocate(combination(NOS,NOD))
    do j = 1, NOD
      do i = 1, NOS
        combination(i,j) = f_combination(i,j)
      end do
    end do
  end subroutine get_combination

  function f_combination(n,k) result(nCk)
    integer, intent(in) :: n, k
    integer :: i
    integer ::nCk

    if(n < k)then
      nCk = 0
      return
    end if

    nCk=1
    do i=1,k
      nCk=nCk*(n-k+i)
      nCk=nCk/i
    end do

  end function f_combination

  pure subroutine insertion_sort(a,NOD)
    integer, intent(in) :: NOD
    integer, intent(inout) :: a(NOD)
    integer :: temp, i, j
    do i = 2, NOD
      j = i - 1
      temp = a(i)
      do while (a(j)>temp)
        a(j+1) = a(j)
        j = j - 1
        if(j==0) exit
      end do
      a(j+1) = temp
    end do
  end subroutine insertion_sort

  integer function inv_list(ni,NOD)
    integer, intent(in) :: NOD
    integer, intent(in) :: ni(NOD)
    integer :: i
    inv_list = ni(1)
    do i = 2, NOD
      inv_list = inv_list + combination(ni(i)-1,i)
    end do
  end function inv_list

  recursive subroutine qsort_w_order(a, o, first, last)
    integer :: a(*), o(*), first, last
    integer :: x, t8, i, j
    integer :: t
    x = a( (first+last) / 2 )
    i = first
    j = last
    do
      do while (a(i) < x)
        i=i+1
      end do
      do while (x < a(j))
        j=j-1
      end do
      if (i >= j) exit
      t8 = a(i);  a(i) = a(j);  a(j) = t8
      t  = o(i);  o(i) = o(j);  o(j) = t
      i=i+1
      j=j-1
    end do
    if (first < i - 1) call qsort_w_order(a, o, first, i - 1)
    if (j + 1 < last)  call qsort_w_order(a, o, j + 1, last)
  end subroutine qsort_w_order

  function list_fly(t,NOD,NOS) result(ni)
    integer, intent(in) :: t, NOD, NOS
    integer :: s
    integer :: i, j, b, j0
    integer :: ni(NOD)
    s = t
    j = NOS - 1
    do i = NOD, 2, -1
       call binary_search(s,combination(:,i), i, j, b, j0)
       j = j0 - 1
       ni(i) = j0
       s = s - combination(j,i)
    end do
    ni(1) = s
  end function list_fly
  !
  subroutine binary_search(s,list_s,ls,le,b,bmin)
    integer, intent(out) :: b, bmin
    integer, intent(in) :: s,ls,le
    integer, intent(in) :: list_s(le)
    integer :: bmax
    bmin = ls; bmax = le
    do
       b = bmin + (bmax-bmin)/2
       if(s<list_s(b))then
          bmax = b-1
       else if(list_s(b)<s)then
          bmin = b+1
       else
          bmin = b
          return
       end if
       if(bmin>bmax)then
          b = -1
          return
       end if
    end do
  end subroutine binary_search

  function j_flip_ni(i,j,n,NOD) result(nd)
    integer, intent(in) :: NOD, i, j, n(NOD)
    integer :: kr, kl
    integer :: nd(NOD)
    nd = 1
    do kr = NOD, 1, -1
      if(j < n(kr)) then
        cycle
      else if(j > n(kr)) then
        exit
      else
        nd = 0; exit
      end if
    end do
    if(nd(NOD) == 1)then ! S+_i S-_j
      do kl = 1, kr
        if(i == n(kl)) exit
      end do
      nd(kl:kr-1) = n(kl+1:kr)
      nd(kr) = j
    else ! S-_i S+_j
      do kl = 1, kr
        if(i < n(kl)) exit
      end do
      nd(kl) = i
      nd(kl+1:kr) = n(kl:kr-1)
    end if
    nd(1:kl-1) = n(1:kl-1)
    nd(kr+1:NOD) = n(kr+1:NOD)
  end function j_flip_ni
  !
  subroutine search_Spi_state_SQ(i,NOD,NOD_new,n,lp)
    integer,intent(in)::i,NOD,NOD_new
    integer,intent(in)::n(1:NOD)
    integer,intent(inout)::lp
    integer::l,kr
    integer, allocatable :: bp(:)
    allocate(bp(1:NOD_new))

    if(NOD>1)then !not FM state
      l = 1
      do kr = 1, NOD
        if(n(kr)==i)then
          l=kr
          exit
        end if
      end do

      bp(1:l-1)=n(1:l-1)
      !bp(l:NOD_new)=n(l+1:NOD)!when l=NOD then this is not operated
      bp(l:NOD-1)=n(l+1:NOD)

    else if (NOD==1.or.NOD==0)then
      print *, "You can not calculate...when sztot=NOS/2-1..."
      stop
    end if

    lp = inv_list(bp,NOD_new)

  end subroutine search_Spi_state_SQ

  subroutine search_Smi_state_SQ(i,NOD,NOD_new,n,lp)
    integer,intent(in)::i,NOD,NOD_new
    integer,intent(in)::n(1:NOD)
    integer,intent(inout)::lp
    integer::l,kr
    integer, allocatable :: bp(:)
    allocate(bp(1:NOD_new))

    if(NOD/=0)then !not FM state
      if(i<n(1))then
        bp(1)=i
        !bp(2:NOD_new)=n(1:NOD)
        bp(2:NOD+1)=n(1:NOD)
      else if(i>n(NOD))then
        bp(1:NOD)=n(1:NOD)
        bp(NOD_new)=i
      else
        l = 1
        do kr = 1, NOD-1
          if(n(kr)<i)then
            l=kr
          else if(n(kr)>i)then
            exit
          end if
        end do

        bp(1:l)=n(1:l)
        bp(l+1)=i
        bp(l+2:NOD+1)=n(l+1:NOD)
      end if
    else if (NOD==0)then
      bp(1)=i
    end if

    lp = inv_list(bp,NOD_new)
    !
  end subroutine search_Smi_state_SQ
  !
end module state_lists


      program t
      print '(i0)',1+2*3
      print '(f3.1)',1+2*3/4.0
      print '(i0)',2**3-1
      end program t


MODULE Param
  USE iso_Fortran_env, ONLY: wp => real64
  IMPLICIT NONE

  ! Calibration
  REAL(wp), PARAMETER :: crra = 2.0_wp ! CRRA
  REAL(wp), PARAMETER :: beta = 0.94_wp ! Discounting
  REAL(wp), PARAMETER :: rf = 0.032_wp ! Risk-free rate
  REAL(wp), PARAMETER :: deltaS = (1.0_wp + rf) / 1.0_wp - rf ! Maturity short
  REAL(wp), PARAMETER :: deltaL = (1.0_wp + rf) / 10.0_wp - rf ! Maturity long
  REAL(wp), PARAMETER :: alpha = 0.945_wp ! Sov bargain power
  REAL(wp), PARAMETER :: eta = 0.33_wp ! Pr negotiations
  REAL(wp), PARAMETER :: etaA = 0.25_wp ! Pr return to market
  REAL(wp), PARAMETER :: muS = 0.5_wp ! Assignment
  REAL(wp), PARAMETER :: lbd0 = -0.85_wp, lbd1 = 1.0_wp
  REAL(wp), PARAMETER :: adj = 0.02_wp, bSshare = 0.33_wp

  REAL(wp), PARAMETER :: kS = deltaS + rf, kL = deltaL + rf

  ! State space
  INTEGER, PARAMETER :: ySz = 21
  INTEGER, PARAMETER :: bSSz = 74, bLSz = 74, bSsplit = 37, bLsplit = 37
  REAL(wp), PARAMETER :: bSmin = 0.0, bSmid = 0.3, bSmax = 0.6
  REAL(wp), PARAMETER :: bLmin = 0.0, bLmid = 0.3, bLmax = 0.6

  INTEGER, PARAMETER :: spaceSz = ySz * bSSz * bLSz

  ! Choice Prs Limit
  INTEGER, PARAMETER :: chPrSz = 300

  ! Numerical
  REAL(wp), PARAMETER :: veryNeg = -1.0D+4, updateQ = 1.0_wp
  REAL(wp), PARAMETER :: epsV = 1.0D-6
  REAL(wp), PARAMETER :: epsQ = 1.0D-4
  ! REAL(wp), PARAMETER :: maxDefPr = 0.15_wp
  REAL(wp), PARAMETER :: minq = 0.7_wp

  REAL(wp), PARAMETER :: rho = 1.0D-5
  REAL(wp), PARAMETER :: rhoDef = rho
  REAL(wp), PARAMETER :: rhoNash = rho

  INTEGER, PARAMETER :: maxIter = 500

  LOGICAL, PARAMETER :: loadGuess = .FALSE.
  LOGICAL, PARAMETER :: computeVFI = .TRUE.
  LOGICAL, PARAMETER :: recovery = .TRUE.
  LOGICAL, PARAMETER :: verbose = .FALSE.

  ! Simulation
  INTEGER, PARAMETER :: simSz = 150002 ! > 5000 only
END MODULE Param


      subroutine seqht(a,lda,m,n,l,b,ldb,ncb)
c------------------------------------------------------------------
c        does sequential reduction of a matrix to upper triangular
c  form using householder transformations.  this algorithm is
c  a fortran implimentation of an algorithm by the same name published
c  in "solving least squares problems", lawson and hanson,
c  prentice hall, 1974.  this routine does steps 5 and 6 of their
c  algorithm with one exception.  this version does not calculate
c  sum of squared residuals but instead projects b onto null of a.
c  consequently b is assumed to lie in array b.  multiple right
c  hand sides are allowed through parameter ncb (see below).
c
c  arguments-
c     a   - m by n array to be reduced to upper triangular form.
c           m .lt. n case is accepted in which case a is reduced to
c           an upper trapezoidal matrix.
c     lda - leading dimension of a in calling program.
c     m   - total number of rows in a.
c     n   - number of columns in a.
c     l   - routine assumes rows 1 to l have already been reduced
c           to upper trapezoidal form by previous calls to this or a
c           similar routine.
c     b   - array of right hand side vectors.  on output b is
c           overwritten by the matrix product q(transpose)*b where
c           q is the matrix defined by householder transformations
c           used to reduce a to upper trapezoidal form.
c     ldb - leading dimension of b in calling program.
c     ncb - number of columns in array b = number of right hand sides
c
c  required subprograms-
c    h12 - householder transformation code from lawson and hanson.
c    test0 - tests for zero columns or rows
c  language - 1977 ansi standard fortran
c  author   - gary l. pavlis
c  written  - may 1981
c------------------------------------------------------------------
      real a(lda,n),b(ldb,ncb)
      integer i,lone
      real up
      external test0
      logical test0
      do 100 i=1,min(n,m-1)
            lone = max(i+1,l+1)
            if(.not.test0(m-lone+1,a(lone,i),1)) then
                  call h12(1,i,lone,m,a(1,i),1,up,a(1,i+1),1,lda,n-i)
                  call h12(2,i,lone,m,a(1,i),1,up,b,1,ldb,ncb)
            endif
  100 continue
      return
      end

c $Id$


      SUBROUTINE mmid(y,dydx,nvar,xs,htot,nstep,yout,derivs)
      INTEGER nstep,nvar,NMAX
      REAL htot,xs,dydx(nvar),y(nvar),yout(nvar)
      EXTERNAL derivs
      PARAMETER (NMAX=50)
      INTEGER i,n
      REAL h,h2,swap,x,ym(NMAX),yn(NMAX)
      h=htot/nstep
      do 11 i=1,nvar
        ym(i)=y(i)
        yn(i)=y(i)+h*dydx(i)
11    continue
      x=xs+h
      call derivs(x,yn,yout)
      h2=2.*h
      do 13 n=2,nstep
        do 12 i=1,nvar
          swap=ym(i)+h2*yout(i)
          ym(i)=yn(i)
          yn(i)=swap
12      continue
        x=x+h
        call derivs(x,yn,yout)
13    continue
      do 14 i=1,nvar
        yout(i)=0.5*(ym(i)+yn(i)+h*yout(i))
14    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/mmid.for


    MODULE cdf_chisq_mod
! ______________________________________________________________________

!                              cdf_chisq_mod
!                              *=*=*=*=*=*=*

!  -  SUBROUTINE CDF_CHISQ( WHICH, CUM, CCUM, X, DF, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CUM_CHISQ(X, DF, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CCUM_CHISQ(X, DF, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION INV_CHISQ( CUM, CCUM, DF, STATUS, CHECK_INPUT)

!                             The Distribution
!                             ================

!   The chi-squared distribution is the distribution of the sum of squares
!   of DF independent unit (mean=0, sd=1) normal deviates.The density is
!              defined on x in [0, +Infinity) and is proportional to :

!                            (DF-2)/2
!                           x         exp(-x/2)

!                                Arguments
!                                =========

!  - INTEGER, INTENT(IN) :: WHICH. Integer indicating which of the next
!    three arguments is to be calculated.
!  Input Range: [ 1:3 ]
!     1.  CUM and CCUM
!     2.  X
!     3.  DF
!  - REAL (dpkind), OPTIONAL :: CUM. The CDF of the chi-squared
!    distribution.
!  Range: [ 0:1-10^-10 ]
!  - REAL (dpkind), OPTIONAL :: CCUM. One minus the CDF of the chi-squared
!    distribution.
!  Range: [ 10^-10:1 ]
!  - REAL (dpkind) :: X. The upper limit of integration of the chi-squared
!    density. The lower limit is 0.
!  Range: [ 0:10^100 ]
!  - REAL (dpkind) :: DF. The degrees of freedom of the chi-squared
!    distribution.
!  Range: [ 10^-3:10^10 ]
!  - INTEGER, OPTIONAL, INTENT(OUT) :: STATUS. Return code. Possible values:
!      0 problem successfully solved
!     -1 WHICH outside input range
!     -2 CUM outside range
!     -3 CCUM outside range
!     -4 X outside range
!     -5 DF outside range
!      3 CUM + CCUM is not nearly one
!      4 X + CX is not nearly one
!     10 Problem could NOT be solved because
!           cdf_gamma (called in local_cum_chisq) has NO solution.
!    -50 Answer (if any) is BELOW the LOWER search bound
!     50 Answer (if any) is ABOVE the UPPER search bound
!  - LOGICAL, INTENT(IN), OPTIONAL :: CHECK_INPUT. If PRESENT and
!       .TRUE. input argument values are not checked for validity.

!       NOTE: CUM and CCUM MUST add to (nearly) one.
! ______________________________________________________________________
! .. Use Statements ..
      USE biomath_constants_mod
! ..
! .. Default Accessibility ..
      PRIVATE
! ..
! .. Public Statements ..
      PUBLIC :: ccum_chisq, cdf_chisq, cum_chisq, inv_chisq
! ..
    CONTAINS

!*********************************************************************

      FUNCTION ccum_chisq(x,df,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: ccum_chisq
! ..
! .. Scalar Arguments ..
        REAL (dpkind) :: df, x
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_chisq(which=1,ccum=ccum_chisq,x=x,df=df,status=status, &
          check_input=check_input)

        RETURN

      END FUNCTION ccum_chisq

!*********************************************************************

      SUBROUTINE cdf_chisq(which,cum,ccum,x,df,status,check_input)
! .. Use Statements ..
        USE cdf_aux_mod
        USE zero_finder
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: ccum, cum
        REAL (dpkind), INTENT (INOUT) :: df, x
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        INTEGER, INTENT (IN) :: which
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
! .. Local Structures ..
        TYPE (zf_locals) :: local
! ..
! .. Local Scalars ..
! .. Local Arrays
        REAL (dpkind) :: fx, local_ccum, local_cum, try_ccum, try_cum
        INTEGER :: zf_status
        LOGICAL :: has_status, local_check_input, match_cum
! ..
! .. Intrinsic Functions ..
        INTRINSIC PRESENT
! ..
! .. Local Arrays ..
        REAL (dpkind) :: params(6)
! ..
        has_status = PRESENT(status)

! status = 0 means NO error

        IF (has_status) THEN
          status = 0
        END IF

        CALL check_complements(cum,ccum,the_chi_square%name,'cum','ccum', &
          local_cum,local_ccum,set_values=(which/=1),bad_status=3, &
          status=status)

        IF (has_status) THEN
          IF (status/=0) THEN
            RETURN
          END IF
        END IF

        params(1) = local_cum
        params(2) = local_ccum
        params(3) = x
        params(4) = df

        IF (PRESENT(check_input)) THEN
          local_check_input = check_input
        ELSE
          local_check_input = .TRUE.
        END IF

        IF (local_check_input) THEN
          CALL validate_parameters(the_chi_square,which,params,status)

          IF (has_status) THEN
            IF (status/=0) THEN
              RETURN
            END IF
          END IF

        END IF

!==========
! Calculate answers
!==========

        IF (which>1) match_cum = (local_cum<=half)

        SELECT CASE (which)

        CASE (1) ! Solve for CDF
          CALL local_cum_chisq(x,df,local_cum,local_ccum,status)

          IF (PRESENT(cum)) cum = local_cum
          IF (PRESENT(ccum)) ccum = local_ccum

        CASE (2) ! Solve for x
          x = five
          zf_status = 0

          CALL cdf_set_zero_finder(the_chi_square,3,local)

          DO
            CALL rc_step_zf(zf_status,x,fx,local)

            IF (zf_status/=1) EXIT

            CALL local_cum_chisq(x,df,try_cum,try_ccum,status)

            IF (has_status) THEN
              IF (status/=0) THEN
                RETURN
              END IF
            END IF

            IF (match_cum) THEN
              fx = try_cum - local_cum
            ELSE
              fx = try_ccum - local_ccum
            END IF
          END DO

        CASE (3) ! Solve for df
          df = five
          zf_status = 0

          CALL cdf_set_zero_finder(the_chi_square,4,local)

          DO
            CALL rc_step_zf(zf_status,df,fx,local)

            IF (zf_status/=1) EXIT

            CALL local_cum_chisq(x,df,try_cum,try_ccum,status)

            IF (has_status) THEN
              IF (status/=0) THEN
                RETURN
              END IF
            END IF

            IF (match_cum) THEN
              fx = try_cum - local_cum
            ELSE
              fx = try_ccum - local_ccum
            END IF
          END DO

        END SELECT

        IF (has_status) THEN
          CALL cdf_finalize_status(local,status)
        END IF

        RETURN

      END SUBROUTINE cdf_chisq

!*********************************************************************

      FUNCTION cum_chisq(x,df,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: cum_chisq
! ..
! .. Scalar Arguments ..
        REAL (dpkind) :: df, x
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_chisq(which=1,cum=cum_chisq,x=x,df=df,status=status, &
          check_input=check_input)

        RETURN

      END FUNCTION cum_chisq

!*********************************************************************

      FUNCTION inv_chisq(cum,ccum,df,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: inv_chisq
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: ccum, cum
        REAL (dpkind) :: df
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_chisq(2,cum,ccum,inv_chisq,df,status,check_input)

        RETURN

      END FUNCTION inv_chisq

!*********************************************************************

      SUBROUTINE local_cum_chisq(x,df,cum,ccum,status)
!----------------------------------------------------------------------
!                    Cumulative Chi Square distribution

!                              Function

!     Computes the integral from 0 to x for the Chi-square distribution.

!                              Arguments

!     x    --> upper limit of integration
!     df   --> degrees of freedom
!     cum  <-- Cumulative chi-square distribution.
!     ccum <-- Complement of Cumulative distribution.

!     STATUS <-- status of the computation.
!                Set to 10 if cdf_gamma has no answer.

!                          Method

!     Formula    26.4.19   of Abramowitz  and     Stegun, Handbook  of
!     Mathematical Functions   (1966) is used   to reduce the chisqure
!     distribution to the incomplete gamma distribution.
!     Computation of other parameters involve a seach for a value that
!     produces  the desired  value  of P.   The search relies  on  the
!     monotinicity of P with the other parameter.
!----------------------------------------------------------------------
! .. Use Statements ..
        USE cdf_gamma_mod
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (OUT) :: ccum, cum
        REAL (dpkind), INTENT (IN) :: df, x
        INTEGER, OPTIONAL, INTENT (OUT) :: status
! ..
! .. Local Scalars ..
        INTEGER :: gamma_status
! ..
! .. Intrinsic Functions ..
        INTRINSIC PRESENT
! ..
        CALL cdf_gamma(1,cum,ccum,half*x,half*df,one,status=gamma_status)

        IF (gamma_status/=0) THEN
! cdf_gamma has NO answer.

          IF (PRESENT(status)) THEN
            status = 10
          ELSE
            WRITE (*,*) 'Error in local_cum_chisq call to cdf_gamma'
            WRITE (*,*) 'Status: ', gamma_status

            STOP 'Error in local_cum_chisq call to cdf_gamma'
          END IF
        END IF

        RETURN

      END SUBROUTINE local_cum_chisq

!*********************************************************************

    END MODULE cdf_chisq_mod


      implicit real*8 (a-h,o-z)
      parameter(n=15)
      dimension xi(n),yi(n),dy(n),dy1(n)
      pi=4.d0*datan(1.d0)
      xmin=-pi
      xmax= pi
      dx=(xmax-xmin)/dfloat(n-1)
      do i=1,n
        xi(i)=xmin+float(i-1)*dx
        yi(i)=sin(xi(i))
      end do
      read *, ndiv
      call nderiv(xi,yi,n,n,ndiv,dy)
      call splderiv(xi,yi,n,n,dy1)
      do i=1,n
        print '(1x,i5,8f12.6)', i,xi(i),yi(i),dy(i)
     &          ,dabs(cos(xi(i))-dy(i))
     &          ,dabs(cos(xi(i))-dy1(i))
      end do
      end

      include 'nderiv.f'


      SUBROUTINE SPECTOP(Dr,N)
      DIMENSION d1(0:32,0:32) , Dr(0:32,0:32) , x(0:32)
      DO k = 0 , N
         fctr2 = o
         DO j = 0 , N
            fctr = fctr1*fctr2
            IF ( j.NE.k ) THEN
               d1(k,j) = ck*fctr/(cj*(x(k)-x(j)))
            ENDIF
            fctr2 = -o*fctr2
         ENDDO
         DO j = 0 , N
            Dr(k,j) = d1(N-k,N-j)
         ENDDO
      ENDDO
      END


      real function dblint(tx,nx,ty,ny,c,kx,ky,xb,xe,yb,ye,wrk)
c  function dblint calculates the double integral
c         / xe  / ye
c        |     |      s(x,y) dx dy
c    xb /  yb /
c  with s(x,y) a bivariate spline of degrees kx and ky, given in the
c  b-spline representation.
c
c  calling sequence:
c     aint = dblint(tx,nx,ty,ny,c,kx,ky,xb,xe,yb,ye,wrk)
c
c  input parameters:
c   tx    : real array, length nx, which contains the position of the
c           knots in the x-direction.
c   nx    : integer, giving the total number of knots in the x-direction
c   ty    : real array, length ny, which contains the position of the
c           knots in the y-direction.
c   ny    : integer, giving the total number of knots in the y-direction
c   c     : real array, length (nx-kx-1)*(ny-ky-1), which contains the
c           b-spline coefficients.
c   kx,ky : integer values, giving the degrees of the spline.
c   xb,xe : real values, containing the boundaries of the integration
c   yb,ye   domain. s(x,y) is considered to be identically zero out-
c           side the rectangle (tx(kx+1),tx(nx-kx))*(ty(ky+1),ty(ny-ky))
c
c  output parameters:
c   aint  : real , containing the double integral of s(x,y).
c   wrk   : real array of dimension at least (nx+ny-kx-ky-2).
c           used as working space.
c           on exit, wrk(i) will contain the integral
c                / xe
c               | ni,kx+1(x) dx , i=1,2,...,nx-kx-1
c           xb /
c           with ni,kx+1(x) the normalized b-spline defined on
c           the knots tx(i),...,tx(i+kx+1)
c           wrk(j+nx-kx-1) will contain the integral
c                / ye
c               | nj,ky+1(y) dy , j=1,2,...,ny-ky-1
c           yb /
c           with nj,ky+1(y) the normalized b-spline defined on
c           the knots ty(j),...,ty(j+ky+1)
c
c  other subroutines required: fpintb
c
c  references :
c    gaffney p.w. : the calculation of indefinite integrals of b-splines
c                   j. inst. maths applics 17 (1976) 37-41.
c    dierckx p. : curve and surface fitting with splines, monographs on
c                 numerical analysis, oxford university press, 1993.
c
c  author :
c    p.dierckx
c    dept. computer science, k.u.leuven
c    celestijnenlaan 200a, b-3001 heverlee, belgium.
c    e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  latest update : march 1989
c
c  ..scalar arguments..
      integer nx,ny,kx,ky
      real xb,xe,yb,ye
c  ..array arguments..
      real tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),wrk(nx+ny-kx-ky-2)
c  ..local scalars..
      integer i,j,l,m,nkx1,nky1
      real res
c  ..
      nkx1 = nx-kx-1
      nky1 = ny-ky-1
c  we calculate the integrals of the normalized b-splines ni,kx+1(x)
      call fpintb(tx,nx,wrk,nkx1,xb,xe)
c  we calculate the integrals of the normalized b-splines nj,ky+1(y)
      call fpintb(ty,ny,wrk(nkx1+1),nky1,yb,ye)
c  calculate the integral of s(x,y)
      dblint = 0.
      do 200 i=1,nkx1
        res = wrk(i)
        if(res.eq.0.) go to 200
        m = (i-1)*nky1
        l = nkx1
        do 100 j=1,nky1
          m = m+1
          l = l+1
          dblint = dblint+res*wrk(l)*c(m)
 100    continue
 200  continue
      return
      end


      SUBROUTINE PTLNDS (PX,PY,PZ, A,B,C,LX,LY,LZ, XN,YN,ZN, DIST)

C  Given a point and a line, find nearest point on line and
C  distance from line to point.

      REAL   PX,PY,PZ, A,B,C,LX,LY,LZ, XN,YN,ZN, DIST, VECL2, VECL
      REAL   DX,DY,DZ, D2ABC, DP, U, DOTPRD

      DX = PX-LX
      DY = PY-LY
      DZ = PZ-LZ
      D2ABC = VECL2 (A,B,C)

      DP = DOTPRD (A,B,C, DX,DY,DZ)
      U  = DP / D2ABC
      XN = LX + A*U
      YN = LY + B*U
      ZN = LZ + C*U

      DIST = VECL (PX-XN, PY-YN, PZ-ZN)

      END


subroutine sld_GetPhysicalParameters(a,J,sz,densi,c_elas,ielem)
   use typre
   use Mod_Solids
   implicit none
   class(SolidsProblem), target :: a
   integer(ip) :: ndime,sz
   real(rp)    :: J,densi, lam, mu,young,nu
   real(rp)    :: c_elas(sz,sz), aux, aux_esf, aux_dev
   real(rp), allocatable :: pStrain(:)
   integer(ip), optional :: ielem

   call a%Mesh%GetNdime(ndime)

   densi = a%densi

   if(a%sld_model == 'NEOHO') then

       !Elastic tensor for neohookean materials
       lam = a%lambda
       mu  = a%mu -lam*log(J)

       if (ndime.eq.2) then

           c_elas =  reshape([ lam + 2.0_rp*mu, lam             ,  0.0_rp, &
                                    lam       , lam + 2.0_rp*mu ,  0.0_rp, &
                                   0.0_rp     ,  0.0_rp         , mu    ], &
               [3,3])

       elseif (ndime.eq.3) then

           c_elas =  reshape([ lam + 2.0_rp*mu, lam, lam, 0.0_rp, 0.0_rp , 0.0_rp, &
                               lam,  lam + 2.0_rp*mu, lam, 0.0_rp, 0.0_rp , 0.0_rp, &
                               lam, lam,  lam + 2.0_rp*mu, 0.0_rp, 0.0_rp , 0.0_rp, &
                               0.0_rp,  0.0_rp, 0.0_rp, mu,  0.0_rp, 0.0_rp, &
                               0.0_rp,  0.0_rp, 0.0_rp,  0.0_rp, mu, 0.0_rp, &
                               0.0_rp,  0.0_rp, 0.0_rp,  0.0_rp,  0.0_rp, mu], &
               [6,6])

       endif

       c_elas =  (1.0_rp/J)*c_elas

   else if(a%sld_model == 'STVEN') then

       c_elas = (1.0_rp/J)*a%c_elastic

   else

       if(a%kfl_modProperties) then

           call a%Memor%alloc(ndime,pStrain,'pStrain','sld_getPhysical')

           pStrain=0.0_rp
           pStrain(:)=a%pStrain(ielem)%a(:)
           nu    = a%poisson
           !From eqn (13), based on square mean value of strains
           !TODO

           !From eqn (15), based on element strain energy density
           !young = ((a%young*(1.0_rp-nu))/(2.0_rp*(1.0_rp-2.0_rp*nu)*(1.0_rp+nu)))*((pStrain(1)**2+pStrain(2)**2) +&
           !    &(2.0_rp*nu/(1.0_rp-nu))*(pStrain(1) + pStrain(2)))

           !From eqn (17), based on distortion energy density, default
           if (ndime.eq.2) then
               young = (a%young/(12.0_rp*(1.0_rp+nu)))*((pStrain(1)-pStrain(2))**2 +&
                       &(pStrain(1))**2 + (pStrain(2))**2)
           else
               young = (a%young/(12.0_rp*(1.0_rp+nu)))*((pStrain(1)-pStrain(2))**2 +&
                       &(pStrain(3)-pStrain(1))**2 + (pStrain(2)-pStrain(3))**2)
           endif

           if(young <= zesld) then
               !If the special case of a totally constrained element occurs,
               !lets say all nodes lie on the boundary, the strain would
               !be equal to zero giving a null young coefficient, hence
               !it's replaced by a small value
               young = 0.1_rp
           end if

          if(a%kfl_printPrincipalStresses) then

              !this is allocated by the ale module
              a%printPStrain(ielem)%a(:,:) = young

          end if

           aux_esf=nu/(1.0_rp-nu)
           aux_dev=(1.0_rp-2.0_rp*nu)/(2.0_rp-2.0_rp*nu)
           aux=young*(1.0_rp-nu)/(1.0_rp-nu-2.0_rp*nu*nu)

           !Elastic tensor for isotropic materials
           if (ndime.eq.2) then

               c_elas =  reshape([ 1.0_rp, aux_esf,  0.0_rp, &
                                  aux_esf,  1.0_rp,  0.0_rp, &
                                   0.0_rp,  0.0_rp, aux_dev], &
                                  [3,3])

           elseif (ndime.eq.3) then

               c_elas =  reshape([ 1.0_rp, aux_esf, aux_esf, 0.0_rp, 0.0_rp , 0.0_rp, &
                                  aux_esf,  1.0_rp, aux_esf, 0.0_rp, 0.0_rp , 0.0_rp, &
                                  aux_esf, aux_esf,  1.0_rp, 0.0_rp, 0.0_rp , 0.0_rp, &
                                  0.0_rp,  0.0_rp, 0.0_rp, aux_dev,  0.0_rp, 0.0_rp, &
                                  0.0_rp,  0.0_rp, 0.0_rp,  0.0_rp, aux_dev, 0.0_rp, &
                                  0.0_rp,  0.0_rp, 0.0_rp,  0.0_rp,  0.0_rp, aux_dev], &
                                  [6,6])

           endif

           c_elas =  aux*c_elas

           call a%Memor%dealloc(ndime,pStrain,'pStrain','sld_getPhysical')

       else

           c_elas = a%c_elastic

       end if
   end if

   end subroutine


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                       .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c ... file shsec.f
c
c     this file contains code and documentation for subroutines
c     shsec and shseci
c
c ... files which must be loaded with shsec.f
c
c     sphcom.f, hrfft.f
c
c     subroutine shsec(nlat,nlon,isym,nt,g,idg,jdg,a,b,mdab,ndab,
c    +                    wshsec,lshsec,work,lwork,ierror)
c
c     subroutine shsec performs the spherical harmonic synthesis
c     on the arrays a and b and stores the result in the array g.
c     the synthesis is performed on an equally spaced grid.  the
c     associated legendre functions are recomputed rather than stored
c     as they are in subroutine shses.  the synthesis is described
c     below at output parameter g.
c
c     required files from spherepack2
c
c     sphcom.f, hrfft.f
c
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     isym   = 0  no symmetries exist about the equator. the synthesis
c                 is performed on the entire sphere.  i.e. on the
c                 array g(i,j) for i=1,...,nlat and j=1,...,nlon.
c                 (see description of g below)
c
c            = 1  g is antisymmetric about the equator. the synthesis
c                 is performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the synthesis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the synthesis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c
c            = 2  g is symmetric about the equator. the synthesis is
c                 performed on the northern hemisphere only.  i.e.
c                 if nlat is odd the synthesis is performed on the
c                 array g(i,j) for i=1,...,(nlat+1)/2 and j=1,...,nlon.
c                 if nlat is even the synthesis is performed on the
c                 array g(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c     nt     the number of syntheses.  in the program that calls shsec,
c            the arrays g,a and b can be three dimensional in which
c            case multiple syntheses will be performed.  the third
c            index is the synthesis index which assumes the values
c            k=1,...,nt.  for a single synthesis set nt=1. the
c            discription of the remaining parameters is simplified
c            by assuming that nt=1 or that the arrays g,a and b
c            have only two dimensions.
c
c     idg    the first dimension of the array g as it appears in the
c            program that calls shsec.  if isym equals zero then idg
c            must be at least nlat.  if isym is nonzero then idg
c            must be at least nlat/2 if nlat is even or at least
c            (nlat+1)/2 if nlat is odd.
c
c     jdg    the second dimension of the array g as it appears in the
c            program that calls shsec.  jdg must be at least nlon.
c
c     a,b    two or three dimensional arrays (see the input parameter
c            nt) that contain the coefficients in the spherical harmonic
c            expansion of g(i,j) given below at the definition of the
c            output parameter g.  a(m,n) and b(m,n) are defined for
c            indices m=1,...,mmax and n=m,...,nlat where mmax is the
c            maximum (plus one) longitudinal wave number given by
c            mmax = min0(nlat,(nlon+2)/2) if nlon is even or
c            mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     mdab   the first dimension of the arrays a and b as it appears
c            in the program that calls shsec. mdab must be at least
c            min0(nlat,(nlon+2)/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndab   the second dimension of the arrays a and b as it appears
c            in the program that calls shsec. ndab must be at least nlat
c
c     wshsec an array which must be initialized by subroutine shseci.
c            once initialized, wshsec can be used repeatedly by shsec
c            as long as nlon and nlat remain unchanged.  wshsec must
c            not be altered between calls of shsec.
c
c     lshsec the dimension of the array wshsec as it appears in the
c            program that calls shsec. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshsec must be at least
c
c            2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls shsec. define
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            if isym is zero then lwork must be at least
c
c                    nlat*(nt*nlon+max0(3*l2,nlon))
c
c            if isym is not zero then lwork must be at least
c
c                    l2*(nt*nlon+max0(3*nlat,nlon))
c
c     **************************************************************
c
c     output parameters
c
c     g      a two or three dimensional array (see input parameter
c            nt) that contains the spherical harmonic synthesis of
c            the arrays a and b at the colatitude point theta(i) =
c            (i-1)*pi/(nlat-1) and longitude point phi(j) =
c            (j-1)*2*pi/nlon. the index ranges are defined above at
c            at the input parameter isym.  for isym=0, g(i,j) is
c            given by the the equations listed below.  symmetric
c            versions are used when isym is greater than zero.
c
c     the normalized associated legendre functions are given by
c
c     pbar(m,n,theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m)))
c                       *sin(theta)**m/(2**n*factorial(n)) times the
c                       (n+m)th derivative of (x**2-1)**n with respect
c                       to x=cos(theta)
c
c     define the maximum (plus one) longitudinal wave number
c     as   mmax = min0(nlat,(nlon+2)/2) if nlon is even or
c          mmax = min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     then g(i,j) = the sum from n=0 to n=nlat-1 of
c
c                   .5*pbar(0,n,theta(i))*a(1,n+1)
c
c              plus the sum from m=1 to m=mmax-1 of
c
c                   the sum from n=m to n=nlat-1 of
c
c              pbar(m,n,theta(i))*(a(m+1,n+1)*cos(m*phi(j))
c                                    -b(m+1,n+1)*sin(m*phi(j)))
c
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of isym
c            = 4  error in the specification of nt
c            = 5  error in the specification of idg
c            = 6  error in the specification of jdg
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lshsec
c            = 10 error in the specification of lwork
c
c
c ****************************************************************
c     subroutine shseci(nlat,nlon,wshsec,lshsec,dwork,ldwork,ierror)
c
c     subroutine shseci initializes the array wshsec which can then
c     be used repeatedly by subroutine shsec.
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     lshsec the dimension of the array wshsec as it appears in the
c            program that calls shseci. the array wshsec is an output
c            parameter which is described below. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshsec must be at least
c
c            2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15
c
c     dwork  a double precision work array that does not have to be
c            saved.
c
c     ldwork the dimension of array dwork as it appears in the program
c            that calls shseci.  ldwork must be at least nlat+1.
c
c     output parameters
c
c     wshsec an array which is initialized for use by subroutine shsec.
c            once initialized, wshsec can be used repeatedly by shsec
c            as long as nlon and nlat remain unchanged.  wshsec must
c            not be altered between calls of shsec.
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lshsec
c            = 4  error in the specification of ldwork
c
c
c ****************************************************************
      SUBROUTINE DSHSEC(NLAT,NLON,ISYM,NT,G,IDG,JDG,A,B,MDAB,NDAB,
     +                  WSHSEC,LSHSEC,WORK,LWORK,IERROR)
      DOUBLE PRECISION G
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION WSHSEC
      DOUBLE PRECISION WORK
      DIMENSION G(IDG,JDG,1),A(MDAB,NDAB,1),B(MDAB,NDAB,1),WSHSEC(1),
     +          WORK(1)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      IF (ISYM.LT.0 .OR. ISYM.GT.2) RETURN
      IERROR = 4
      IF (NT.LT.0) RETURN
      IERROR = 5
      IF ((ISYM.EQ.0.AND.IDG.LT.NLAT) .OR.
     +    (ISYM.NE.0.AND.IDG.LT. (NLAT+1)/2)) RETURN
      IERROR = 6
      IF (JDG.LT.NLON) RETURN
      IERROR = 7
      MMAX = MIN0(NLAT,NLON/2+1)
      IF (MDAB.LT.MMAX) RETURN
      IERROR = 8
      IF (NDAB.LT.NLAT) RETURN
      IERROR = 9
      IMID = (NLAT+1)/2
      LZZ1 = 2*NLAT*IMID
      LABC = 3* ((MMAX-2)* (NLAT+NLAT-MMAX-1))/2
      IF (LSHSEC.LT.LZZ1+LABC+NLON+15) RETURN
      IERROR = 10
      LS = NLAT
      IF (ISYM.GT.0) LS = IMID
      NLN = NT*LS*NLON
      IF (LWORK.LT.NLN+MAX0(LS*NLON,3*NLAT*IMID)) RETURN
      IERROR = 0
      IST = 0
      IF (ISYM.EQ.0) IST = IMID
      IW1 = LZZ1 + LABC + 1
      CALL DSHSEC1(NLAT,ISYM,NT,G,IDG,JDG,A,B,MDAB,NDAB,IMID,LS,NLON,
     +            WORK,WORK(IST+1),WORK(NLN+1),WORK(NLN+1),WSHSEC,
     +            WSHSEC(IW1))
      RETURN
      END
      SUBROUTINE DSHSEC1(NLAT,ISYM,NT,G,IDGS,JDGS,A,B,MDAB,NDAB,IMID,
     +                   IDG,JDG,GE,GO,WORK,PB,WALIN,WHRFFT)
      DOUBLE PRECISION G
      DOUBLE PRECISION A
      DOUBLE PRECISION B
      DOUBLE PRECISION GE
      DOUBLE PRECISION GO
      DOUBLE PRECISION WORK
      DOUBLE PRECISION PB
      DOUBLE PRECISION WALIN
      DOUBLE PRECISION WHRFFT
c
c     whrfft must have at least nlon+15 locations
c     walin must have 3*l*imid + 3*((l-3)*l+2)/2 locations
c     zb must have 3*l*imid locations
c
      DIMENSION G(IDGS,JDGS,1),A(MDAB,NDAB,1),B(MDAB,NDAB,1),
     +          GE(IDG,JDG,1),GO(IDG,JDG,1),PB(IMID,NLAT,3),WALIN(1),
     +          WHRFFT(1),WORK(1)

      LS = IDG
      NLON = JDG
      MMAX = MIN0(NLAT,NLON/2+1)
      MDO = MMAX
      IF (MDO+MDO-1.GT.NLON) MDO = MMAX - 1
      NLP1 = NLAT + 1
      MODL = MOD(NLAT,2)
      IMM1 = IMID
      IF (MODL.NE.0) IMM1 = IMID - 1
      DO 80 K = 1,NT
          DO 80 J = 1,NLON
              DO 80 I = 1,LS
                  GE(I,J,K) = 0.D0
   80 CONTINUE
      IF (ISYM.EQ.1) GO TO 125
      CALL DALIN(2,NLAT,NLON,0,PB,I3,WALIN)
      DO 100 K = 1,NT
          DO 100 NP1 = 1,NLAT,2
              DO 100 I = 1,IMID
                  GE(I,1,K) = GE(I,1,K) + A(1,NP1,K)*PB(I,NP1,I3)
  100 CONTINUE
      NDO = NLAT
      IF (MOD(NLAT,2).EQ.0) NDO = NLAT - 1
      DO 110 MP1 = 2,MDO
          M = MP1 - 1
          CALL DALIN(2,NLAT,NLON,M,PB,I3,WALIN)
          DO 110 NP1 = MP1,NDO,2
              DO 110 K = 1,NT
                  DO 110 I = 1,IMID
                      GE(I,2*MP1-2,K) = GE(I,2*MP1-2,K) +
     +                                  A(MP1,NP1,K)*PB(I,NP1,I3)
                      GE(I,2*MP1-1,K) = GE(I,2*MP1-1,K) +
     +                                  B(MP1,NP1,K)*PB(I,NP1,I3)
  110 CONTINUE
      IF (MDO.EQ.MMAX .OR. MMAX.GT.NDO) GO TO 122
      CALL DALIN(2,NLAT,NLON,MDO,PB,I3,WALIN)
      DO 120 NP1 = MMAX,NDO,2
          DO 120 K = 1,NT
              DO 120 I = 1,IMID
                  GE(I,2*MMAX-2,K) = GE(I,2*MMAX-2,K) +
     +                               A(MMAX,NP1,K)*PB(I,NP1,I3)
  120 CONTINUE
  122 IF (ISYM.EQ.2) GO TO 155
  125 CALL DALIN(1,NLAT,NLON,0,PB,I3,WALIN)
      DO 140 K = 1,NT
          DO 140 NP1 = 2,NLAT,2
              DO 140 I = 1,IMM1
                  GO(I,1,K) = GO(I,1,K) + A(1,NP1,K)*PB(I,NP1,I3)
  140 CONTINUE
      NDO = NLAT
      IF (MOD(NLAT,2).NE.0) NDO = NLAT - 1
      DO 150 MP1 = 2,MDO
          MP2 = MP1 + 1
          M = MP1 - 1
          CALL DALIN(1,NLAT,NLON,M,PB,I3,WALIN)
          DO 150 NP1 = MP2,NDO,2
              DO 150 K = 1,NT
                  DO 150 I = 1,IMM1
                      GO(I,2*MP1-2,K) = GO(I,2*MP1-2,K) +
     +                                  A(MP1,NP1,K)*PB(I,NP1,I3)
                      GO(I,2*MP1-1,K) = GO(I,2*MP1-1,K) +
     +                                  B(MP1,NP1,K)*PB(I,NP1,I3)
  150 CONTINUE
      MP2 = MMAX + 1
      IF (MDO.EQ.MMAX .OR. MP2.GT.NDO) GO TO 155
      CALL DALIN(1,NLAT,NLON,MDO,PB,I3,WALIN)
      DO 152 NP1 = MP2,NDO,2
          DO 152 K = 1,NT
              DO 152 I = 1,IMM1
                  GO(I,2*MMAX-2,K) = GO(I,2*MMAX-2,K) +
     +                               A(MMAX,NP1,K)*PB(I,NP1,I3)
  152 CONTINUE
  155 DO 160 K = 1,NT
          IF (MOD(NLON,2).NE.0) GO TO 157
          DO 156 I = 1,LS
              GE(I,NLON,K) = 2.D0*GE(I,NLON,K)
  156     CONTINUE
  157     CALL DHRFFTB(LS,NLON,GE(1,1,K),LS,WHRFFT,WORK)
  160 CONTINUE
      IF (ISYM.NE.0) GO TO 180
      DO 170 K = 1,NT
          DO 170 J = 1,NLON
              DO 175 I = 1,IMM1
                  G(I,J,K) = .5D0* (GE(I,J,K)+GO(I,J,K))
                  G(NLP1-I,J,K) = .5D0* (GE(I,J,K)-GO(I,J,K))
  175         CONTINUE
              IF (MODL.EQ.0) GO TO 170
              G(IMID,J,K) = .5D0*GE(IMID,J,K)
  170 CONTINUE
      RETURN
  180 DO 185 K = 1,NT
          DO 185 I = 1,IMID
              DO 185 J = 1,NLON
                  G(I,J,K) = .5D0*GE(I,J,K)
  185 CONTINUE
      RETURN
      END
c     subroutine shseci(nlat,nlon,wshsec,lshsec,dwork,ldwork,ierror)
c
c     subroutine shseci initializes the array wshsec which can then
c     be used repeatedly by subroutine shsec.
c
c     input parameters
c
c     nlat   the number of colatitudes on the full sphere including the
c            poles. for example, nlat = 37 for a five degree grid.
c            nlat determines the grid increment in colatitude as
c            pi/(nlat-1).  if nlat is odd the equator is located at
c            grid point i=(nlat+1)/2. if nlat is even the equator is
c            located half way between points i=nlat/2 and i=nlat/2+1.
c            nlat must be at least 3. note: on the half sphere, the
c            number of grid points in the colatitudinal direction is
c            nlat/2 if nlat is even or (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than or equal to 4. the efficiency of the computation is
c            improved when nlon is a product of small prime numbers.
c
c     lshsec the dimension of the array wshsec as it appears in the
c            program that calls shseci. the array wshsec is an output
c            parameter which is described below. define
c
c               l1 = min0(nlat,(nlon+2)/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lshsec must be at least
c
c            2*nlat*l2+3*((l1-2)*(nlat+nlat-l1-1))/2+nlon+15
c
c     dwork  a double precision work array that does not have to be
c            saved.
c
c     ldwork the dimension of array dwork as it appears in the program
c            that calls shseci.  ldwork must be at least nlat+1.
c
c     output parameters
c
c     wshsec an array which is initialized for use by subroutine shsec.
c            once initialized, wshsec can be used repeatedly by shsec
c            as long as nlon and nlat remain unchanged.  wshsec must
c            not be altered between calls of shsec.
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lshsec
c            = 4  error in the specification of ldwork
c
c
c ****************************************************************
      SUBROUTINE DSHSECI(NLAT,NLON,WSHSEC,LSHSEC,DWORK,LDWORK,IERROR)
      DOUBLE PRECISION WSHSEC
      DIMENSION WSHSEC(*)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(LDWORK)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.4) RETURN
      IERROR = 3
      IMID = (NLAT+1)/2
      MMAX = MIN0(NLAT,NLON/2+1)
      LZZ1 = 2*NLAT*IMID
      LABC = 3* ((MMAX-2)* (NLAT+NLAT-MMAX-1))/2
      IF (LSHSEC.LT.LZZ1+LABC+NLON+15) RETURN
      IERROR = 4
      IF (LDWORK.LT.NLAT+1) RETURN
      IERROR = 0
      CALL DALINIT(NLAT,NLON,WSHSEC,DWORK)
      IW1 = LZZ1 + LABC + 1
      CALL DHRFFTI(NLON,WSHSEC(IW1))
      RETURN
      END


      SUBROUTINE dftint(func,a,b,w,cosint,sinint)
      INTEGER M,NDFT,MPOL
      REAL a,b,cosint,sinint,w,func,TWOPI
      PARAMETER (M=64,NDFT=1024,MPOL=6,TWOPI=2.*3.14159265)
      EXTERNAL func
CU    USES dftcor,func,polint,realft
      INTEGER init,j,nn
      REAL aold,bold,c,cdft,cerr,corfac,corim,corre,delta,en,s,sdft,
     *serr,cpol(MPOL),data(NDFT),endpts(8),spol(MPOL),xpol(MPOL)
      SAVE init,aold,bold,delta,data,endpts
      DATA init/0/,aold/-1.e30/,bold/-1.e30/
      if (init.ne.1.or.a.ne.aold.or.b.ne.bold) then
        init=1
        aold=a
        bold=b
        delta=(b-a)/M
        do 11 j=1,M+1
          data(j)=func(a+(j-1)*delta)
11      continue
        do 12 j=M+2,NDFT
          data(j)=0.
12      continue
        do 13 j=1,4
          endpts(j)=data(j)
          endpts(j+4)=data(M-3+j)
13      continue
        call realft(data,NDFT,1)
        data(2)=0.
      endif
      en=w*delta*NDFT/TWOPI+1.
      nn=min(max(int(en-0.5*MPOL+1.),1),NDFT/2-MPOL+1)
      do 14 j=1,MPOL
        cpol(j)=data(2*nn-1)
        spol(j)=data(2*nn)
        xpol(j)=nn
        nn=nn+1
14    continue
      call polint(xpol,cpol,MPOL,en,cdft,cerr)
      call polint(xpol,spol,MPOL,en,sdft,serr)
      call dftcor(w,delta,a,b,endpts,corre,corim,corfac)
      cdft=cdft*corfac+corre
      sdft=sdft*corfac+corim
      c=delta*cos(w*a)
      s=delta*sin(w*a)
      cosint=c*cdft-s*sdft
      sinint=s*cdft+c*sdft
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/dftint.for


! Copyright (C) 2017-2019 Matthieu Ancellin
! See LICENSE file at <https://github.com/mancellin/libDelhommeau>

MODULE CONSTANTS

  INTEGER, PARAMETER :: PRE = KIND(1d0) ! Floating point numbers precision

  REAL(KIND=PRE), PARAMETER :: ZERO = 0
  REAL(KIND=PRE), PARAMETER :: ONE = 1
  REAL(KIND=PRE), PARAMETER :: INFINITE_DEPTH = 0

  REAL(KIND=PRE), PARAMETER :: PI = 3.141592653588979 ! π
  COMPLEX(KIND=PRE), PARAMETER :: II = (0, 1)         ! Imaginary unit

END MODULE CONSTANTS


! { dg-options "-O2 -fgraphite-identity -fno-loop-block -fno-loop-interchange -fno-loop-strip-mine" }

MODULE beta_gamma_psi
  INTEGER, PARAMETER :: dp=KIND(0.0D0)
CONTAINS
  FUNCTION basym () RESULT(fn_val)
    REAL(dp) :: b0(21), bsum, d(21)
    DO n = 2, num, 2
       DO i = n, np1
          b0(1) = 1
          DO m = 2, i
             mm1 = m - 1
             DO j = 1, mm1
                bsum = bsum + b0(j)
             END DO
             b0(m) = bsum
          END DO
          d(i) = -b0(i)
       END DO
       sum = sum + d(n)
    END DO
    fn_val = sum
  END FUNCTION basym
END MODULE beta_gamma_psi
! { dg-final { cleanup-modules "beta_gamma_psi" } }


program main
    use mpi
    implicit none
    integer :: ntasks, rank, ierr
    integer, allocatable :: status(:)
    integer :: clock, n
    integer, allocatable :: seed(:)
    integer(4) :: i, n_tot = 125000000
    real(8), parameter :: pi = acos(-1.d0)
    real(8), parameter :: phi_l = 0.d0, phi_u = 2.d0 * pi, rho_l = 0.d0, rho_u = 3.d0, z_l = -3.d0, z_u = 3.d0
    real(8) :: phi, rho, z, f, H
    real(8) :: integral_local = 0.d0, integral
    real :: start, finish, time
    real(8) :: sigma

    ! initialize the MPI environment
    call MPI_INIT(ierr)
    call MPI_COMM_SIZE(MPI_COMM_WORLD, ntasks, ierr)
    call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr)
    allocate(status(MPI_STATUS_SIZE))

    call CPU_TIME(start)

    ! initialize the random number for different processes
    if (rank == 0) then
        call SYSTEM_CLOCK(clock)
        call RANDOM_SEED(size = n)
        allocate(seed(n))
        do i = 1, n
            seed(i) = clock + 37 * i
        end do
        call RANDOM_SEED(PUT = seed)
        deallocate(seed)
        do i = 1, ntasks - 1
            call RANDOM_NUMBER(z)
            clock = clock + Int(z * 1000000)
            call MPI_SEND(clock, 1, MPI_INTEGER, i, i, MPI_COMM_WORLD, ierr)
        end do
    else
        call MPI_RECV(clock, 1, MPI_INTEGER, 0, rank, MPI_COMM_WORLD, status, ierr)
        call RANDOM_SEED(size = n)
        allocate(seed(n))
        do i = 1, n
            seed(i) = clock + 37 * i
        end do
        call RANDOM_SEED(PUT = seed)
        deallocate(seed)
    end if

    do i = 1, n_tot
        call RANDOM_NUMBER(phi)
        phi = phi * (phi_u - phi_l) + phi_l
        call RANDOM_NUMBER(rho)
        rho = rho * (rho_u - rho_l) + rho_l
        call RANDOM_NUMBER(z)
        z = z * (z_u - z_l) + z_l
        call func(phi, rho, z, f)
        call inArea(phi, rho, z, H)
        integral_local = integral_local + f * H
    end do
    integral_local = (phi_u - phi_l) * (rho_u - rho_l) * (z_u - z_l) / dble(n_tot) * integral_local

    call MPI_REDUCE(integral_local, integral, 1, MPI_REAL8, MPI_SUM, 0, MPI_COMM_WORLD, ierr)

    if (rank == 0) then
        integral = integral / dble(ntasks)
        write(*,'(f10.5)') integral
    end if

    call CPU_TIME(finish)
    call MPI_REDUCE(finish - start, time, 1, MPI_REAL, MPI_SUM, 0, MPI_COMM_WORLD, ierr)
    if (rank == 0) then
        write(*,'("Time consumed: ",f10.5)') time
    end if
    call MPI_REDUCE(((integral_local - dble(648) * pi / dble(5))**2)**2, sigma, 1, MPI_REAL8, MPI_SUM, 0, MPI_COMM_WORLD, ierr)
    if (rank == 0) then
        write(*,'("Error: ",f10.5)') sqrt(sigma / dble(ntasks))
    end if

    call MPI_FINALIZE(ierr)
end program main

subroutine func(phi, rho, z, f)
    ! the function to be integrated
    implicit none
    real(8), intent(in) :: phi, rho, z
    real(8), intent(out) :: f

    f = rho**3
end subroutine func

subroutine inArea(phi, rho, z, H)
    ! judge whether the dot is in the integral area
    real(8), intent(in) :: phi, rho, z
    real(8), intent(out) :: H

    if ((z > -sqrt(9.d0 - rho**2)) .and. (z < sqrt(9.d0 - rho**2))) then
        H = 1.d0
    else
        H = 0.d0
    end if
end subroutine inArea


! implement a recursive descent parser
module evaluate_algebraic_expression

  integer, parameter :: size = 124
  character, parameter :: statement_end = achar(0)
  character(len=size) :: text_to_parse
  integer :: position
  data position/0/,text_to_parse/' '/

contains

  character function get_token()
    ! return the current token
    implicit none
    if (position <= size) then
       get_token = text_to_parse(position:position)
       do while (get_token <= ' ')
          call advance
          if (size < position) exit
          get_token = text_to_parse(position:position)
       end do
    end if
    if (size < position) get_token = statement_end
  end function get_token

  subroutine advance ! consume a token.  Move to the next token.  consume_token would have been a better name.
    position = position + 1
  end subroutine advance

  logical function unfinished()
    unfinished = get_token() /= statement_end
  end function unfinished

  subroutine parse_error()
    write(6,*)'"'//get_token()//'" unexpected in expression at',position
    stop 1
  end subroutine parse_error

  function precedence3() result(a)
    implicit none
    real :: a
    character :: token
    character(len=10), parameter :: digits = '0123456789'
    token = get_token()
    if (verify(token,digits) /= 0) call parse_error()
    a = index(digits, token) - 1
    call advance()
  end function precedence3

  recursive function precedence2() result(a)
    real :: a
    character :: token
    token = get_token()
    if (token /= '(') then
       a = precedence3()
    else
       call advance
       a = precedence0()
       token = get_token()
       if (token /= ')') call parse_error()
       call advance
    end if
  end function precedence2

  recursive function precedence1() result(a)
    implicit none
    real :: a
    real, dimension(2) :: argument
    character(len=2), parameter :: tokens = '*/'
    character :: token
    a = 0
    token = get_token()
    argument(1) = precedence2()
    token = get_token()
    do while (verify(token,tokens) == 0)
       call advance()
       argument(2) = precedence2()
       if (token == '/') argument(2) = 1 / argument(2)
       argument(1) = product(argument)
       token = get_token()
    end do
    a = argument(1)
  end function precedence1

  recursive function precedence0() result(a)
    implicit none
    real :: a
    real, dimension(2) :: argument
    character(len=2), parameter :: tokens = '+-'
    character :: token
    a = 0
    token = get_token()
    argument(1) = precedence1()
    token = get_token()
    do while (verify(token,tokens) == 0)
       call advance()
       argument(2) = precedence1()
       if (token == '-') argument = argument * (/1, -1/)
       argument(1) = sum(argument)
       token = get_token()
    end do
    a = argument(1)
  end function precedence0

  real function statement()
    implicit none
    if (unfinished()) then
       statement = precedence0()
    else                        !empty okay
       statement = 0
    end if
    if (unfinished()) call parse_error()
  end function statement

  real function evaluate(expression)
    implicit none
    character(len=*), intent(in) :: expression
    text_to_parse = expression
    evaluate = statement()
  end function evaluate

end module evaluate_algebraic_expression

program g24
  use evaluate_algebraic_expression
  implicit none
  integer, dimension(4) :: digits
  character(len=78) :: expression
  real :: result
  ! integer :: i
  call random_seed!easily found internet examples exist to seed by /dev/urandom or time
  call deal(digits)
  ! do i=1, 9999 ! produce the data to test digit distribution
  !   call deal(digits)
  !   write(6,*) digits
  ! end do
  write(6,'(a13,4i2,a26)')'Using digits',digits,', and the algebraic dyadic'
  write(6,*)'operators +-*/() enter an expression computing 24.'
  expression = ' '
  read(5,'(a78)') expression
  if (invalid_digits(expression, digits)) then
     write(6,*)'invalid digits'
  else
     result = evaluate(expression)
     if (nint(result) == 24) then
        write(6,*) result, ' close enough'
     else
        write(6,*) result, ' no good'
     end if
  end if

contains

  logical function invalid_digits(e,d) !verify the digits
    implicit none
    character(len=*), intent(in) :: e
    integer, dimension(4), intent(inout) :: d
    integer :: i, j, k, count
    logical :: unfound
    count = 0
    invalid_digits = .false. !validity assumed
    !write(6,*)'expression:',e(1:len_trim(e))
    do i=1, len_trim(e)
       if (verify(e(i:i),'0123456789') == 0) then
          j = index('0123456789',e(i:i))-1
          unfound = .true.
          do k=1, 4
             if (j == d(k)) then
                unfound = .false.
                exit
             end if
          end do
          if (unfound) then
             invalid_digits = .true.
             !return or exit is okay here
          else
             d(k) = -99
             count = count + 1
          end if
       end if
    end do
    invalid_digits = invalid_digits .or. (count /= 4)
  end function invalid_digits

  subroutine deal(digits)
    implicit none
    integer, dimension(4), intent(out) :: digits
    integer :: i
    real :: harvest
    call random_number(harvest)
    do i=1, 4
       digits(i) = int(mod(harvest*9**i, 9.0))   + 1
    end do
    !    NB. computed with executable Iverson notation, www.jsoftware.oom
    !    #B NB. B are the digits from 9999 deals
    ! 39996
    !    ({.,#)/.~/:~B  # show the distribution of digits
    ! 0 4380
    ! 1 4542
    ! 2 4348
    ! 3 4395
    ! 4 4451
    ! 5 4474
    ! 6 4467
    ! 7 4413
    ! 8 4526
    !    NB. this also shows that I forgot to add 1.  Inserting now...
  end subroutine deal
end program g24


!> Denis Sergeev, UEA
!> Solves the one dimensional heat diffusion equation
!> \( \frac{\partial H}{\partial t}
!> - \kappa\frac{\partial^{2} H}{\partial x^{2}} = f(x) \)
program fd1d_heat_explicit_prb
  ! use plplot
  use plfortrandemolib

  use types_mod, only: DP, SI
  use cfl_mod, only: fd1d_heat_explicit_cfl
  use io_mod, only: r8vec_linspace, r8mat_write !, r8vec_write
  use solver_mod, only: fd1d_heat_explicit

  implicit none

  integer(kind=SI), parameter :: T_NUM = 201
  integer(kind=SI), parameter :: X_NUM = 21

  real (kind=DP)                  :: cfl
  real (kind=DP)                  :: dt
  real (kind=DP), allocatable, dimension(:)    :: h
  real (kind=DP), allocatable, dimension(:)    :: h_new
! the "matrix" stores all x-values for all t-values
! remember Fortran is column major, meaning that rows are contiguous
  real (kind=DP), allocatable, dimension(:, :) :: hmat
  integer(kind=SI)                         :: i
  integer(kind=SI)                         :: j
  real (kind=DP)                  :: k

  real (kind=DP), allocatable, dimension(:)    :: t
  real (kind=DP)                  :: t_max
  real (kind=DP)                  :: t_min
  real (kind=DP), allocatable, dimension(:)    :: x
  real (kind=DP)                  :: x_max
  real (kind=DP)                  :: x_min
  integer(kind=SI)                         :: ierr
  character (len=12) :: imgname

  allocate(h    (1:X_NUM         ), stat=ierr)
  allocate(h_new(1:X_NUM         ), stat=ierr)
  allocate(hmat (1:X_NUM, 1:T_NUM), stat=ierr)
  allocate(t    (         1:T_NUM), stat=ierr)
  allocate(x    (1:X_NUM         ), stat=ierr)
  if ( ierr /= 0 ) then
    write(*, '(a)') 'Failed to allocate arrays'
  end if

  write (*, '(a)') ' '
  write (*, '(a)') 'FD1D_HEAT_EXPLICIT_PRB:'
  write (*, '(a)') '  FORTRAN77 version.'
  write (*, '(a)') '  Test the FD1D_HEAT_EXPLICIT library.'

  write (*, '(a)') ' '
  write (*, '(a)') 'FD1D_HEAT_EXPLICIT_PRB:'
  write (*, '(a)') '  Normal end of execution.'
  write (*, '(a)') ' '

  write (*, '(a)') ' '
  write (*, '(a)') 'FD1D_HEAT_EXPLICIT_TEST01:'
  write (*, '(a)') '  Compute an approximate solution to the time-dependent'
  write (*, '(a)') '  one dimensional heat equation:'
  write (*, '(a)') ' '
  write (*, '(a)') '    dH/dt - K * d2H/dx2 = f(x,t)'
  write (*, '(a)') ' '
  write (*, '(a)') '  Run a simple test case.'

! heat coefficient
  k = 0.002e+00_DP

! the x-range values
  x_min = 0.0e+00_DP
  x_max = 1.0e+00_DP
! X_NUM is the number of intervals in the x-direction
  call r8vec_linspace(x_min, x_max, x)

! the t-range values. integrate from t_min to t_max
  t_min = 0.0e+00_DP
  t_max = 80.0e+00_DP

! T_NUM is the number of intervals in the t-direction
  dt = (t_max-t_min)/real(T_NUM-1, kind=DP)
  call r8vec_linspace(t_min, t_max, t)

! get the CFL coefficient
  call fd1d_heat_explicit_cfl(k, T_NUM, t_min, t_max, X_NUM, x_min, x_max, &
    cfl)

  if (0.5e+00_DP<=cfl) then
    write (*, '(a)') ' '
    write (*, '(a)') 'FD1D_HEAT_EXPLICIT_CFL - Fatal error!'
    write (*, '(a)') '  CFL condition failed.'
    write (*, '(a)') '  0.5 <= K * dT / dX / dX = CFL.'
    stop
  end if

! set the initial condition
  do j = 1, X_NUM
    h(j) = 50.0e+00_DP
  end do

! set the bounday condition
  h(1) = 90.0e+00_DP
  h(X_NUM) = 70.0e+00_DP

! initialise the matrix to the initial condition
  do i = 1, X_NUM
    hmat(i, 1) = h(i)
  end do

! the main time integration loop
  do j = 2, T_NUM
    call fd1d_heat_explicit(x, dt, cfl, h, h_new)
    ! call fd1d_heat_explicit(x, t(j-1), dt, cfl, h, h_new)

    do i = 1, X_NUM
      hmat(i, j) = h_new(i)
      h(i) = h_new(i)
    end do
    ! Plotting
    if (mod( j, 10) == 0) then
      write( imgname, '(A,I3.3,A)' ) 'image', j, '.png'
      print*, imgname

      call PLSFNAM( imgname )
      call PLSDEV( 'pngcairo' )
      call PLINIT( )
      call PLENV( minval(x(:)), maxval(x(:)), minval(h(:)), maxval(h(:)), 0, 0 )
      call PLLAB( 'x-axis', 'y-axis', 'mytitle' )
      call PLLINE( x(:), h_new(:) )
      call PLEND( )
    end if

  end do

! write data to files
  call r8mat_write('h_test01.nc', t, x, hmat)

  deallocate(h    )
  deallocate(h_new)
  deallocate(hmat )
  deallocate(t    )
  deallocate(x    )

end program fd1d_heat_explicit_prb


PROGRAM FIZZBUZZ

  IMPLICIT NONE

  INTEGER :: i, max_num

  max_num = 100  ! Classic FizzBuzz runs from 1 to 100

  DO i = 1, max_num

    ! Start by considering divides by 3 AND 5
    ! The MOD function returns the remainder of division
    ! SO MOD(4, 3) -> 1 and MOD(7, 5) -> 2 etc
    ! For the first case, we could also do:
    ! IF(MOD(i, 3) == 0 .AND. MOD(i, 5) == 0) THEN
    IF(MOD(i, 15) == 0) THEN
      ! Divides by 15 i.e. by 5 and by 3
      PRINT*, "Fizzbuzz"
    ELSE IF(MOD(i, 3) == 0) THEN
      !Divdes by 3 but NOT 5
      PRINT*, "Fizz"
    ELSE IF(MOD(i, 5) == 0) THEN
      !Divdes by 5 but NOT 3
      PRINT*, "Buzz"
    ELSE
      ! Format as an integer with up to 8 digits
      PRINT'(I8)', i
    END IF

  ENDDO

END PROGRAM


      program lonlat_dist
      implicit none
c
      character*240 cfilea,cfileb,cline
      integer       ios,l
      logical       lsum,skip_new,skip_old
      real          lat1,lat2,lon1,lon2,dist,distmax
      real*8        dist_sum
      real*4        spherdist
c
c  lonlat_dist - Usage:  lonlat_dist in.txt out.txt [maxdist]
C                    lonlat_dist_sum in.txt out.txt
c
c                 adds the distance in km to a list of lon,lat values
c
c  lonlat_dist_sum calculates the distance from the 1st point.
c
c  if maxdist is present, it instead addd a blank line before any
c   distance greater than maxdist
c
c --- each line of in.txt should contain:
c ---   a) a lon,lat pair, or
c ---   b) is blank, or
c ---   c) a comment starting with #, or
c ---   d) a mark-type (number) preceeded by >>>
c ---   e) a label preceeded by ***
c ---   f) a polyline color index preceeded by +++
c
      integer       iargc
      integer       narg
      character*240 carg
c
c     read arguments.
c
      call getarg(0,carg)
      l = len_trim(carg)
      lsum = carg(l-3:l) .eq. "_sum"
c
      narg = iargc()
C
      if     (narg.eq.3 .and. .not.lsum) then
        call getarg(1,cfilea)
        call getarg(2,cfileb)
        call getarg(3,carg)
        read(carg,*) distmax
      elseif (narg.eq.2) then
        call getarg(1,cfilea)
        call getarg(2,cfileb)
        distmax = -1.0
      ELSEIF (lsum) then
        WRITE(6,*)
     +  'Usage: lonlat_dist_sum in.txt out.txt'
        CALL EXIT(1)
      ELSE
        WRITE(6,*)
     +  'Usage: lonlat_dist in.txt out.txt [maxdist]'
        CALL EXIT(1)
      ENDIF
c
      open(unit=11, file=cfilea, form='formatted', status='old',
     +     iostat=ios)
      if     (ios.ne.0) then
        write(6,*) 'Error: can''t open ',trim(cfilea)
        write(6,*) 'ios   = ',ios
        call exit(3)
      endif
      open(unit=21, file=cfileb, form='formatted', status='new',
     +     iostat=ios)
      if     (ios.ne.0) then
        write(6,*) 'Error: can''t open ',trim(cfileb)
        write(6,*) 'ios   = ',ios
        call exit(5)
      endif
c
      read(11,'(a)') cline
      skip_new = cline     .eq.' '   .or.
     &           cline(1:1).eq.'#'   .or.
     &           cline(1:3).eq.'>>>' .or.
     &           cline(1:3).eq.'+++' .or.
     &           cline(1:3).eq.'***'
      if     (skip_new) then
        lon2 = 0.0
        lat2 = 0.0
        write(21,'(a)') trim(cline)
      elseif (distmax.lt.0.0) then
        read(cline,*) lon2,lat2
        dist_sum = 0.d0
        write(21,'(a,f12.4)') trim(cline),0.0
      else
        read(cline,*) lon2,lat2
        dist_sum = 0.d0
        write(21,'(a,f12.4)') trim(cline)
      endif
c
      do
        read(unit=11,end=100,fmt='(a)') cline
        skip_old = skip_new
        skip_new = cline     .eq.' '   .or.
     &             cline(1:1).eq.'#'   .or.
     &             cline(1:3).eq.'>>>' .or.
     &             cline(1:3).eq.'+++' .or.
     &             cline(1:3).eq.'***'
c
        if     (skip_new) then
          write(21,'(a)') trim(cline)
        else
          lon1 = lon2
          lat1 = lat2
          read(cline,*) lon2,lat2
          if     (skip_old) then
            if     (distmax.lt.0.0) then
              dist_sum = 0.d0
              write(21,'(a,f12.4)') trim(cline),0.0
            else
              write(21,'(a)') trim(cline)
            endif
          else
            dist = 0.001*spherdist(lon1,lat1,lon2,lat2)
            if     (lsum) then
              dist_sum = dist_sum + dist
              write(21,'(a,f12.4)') trim(cline),dist_sum
            elseif (distmax.lt.0.0) then
              write(21,'(a,f12.4)') trim(cline),dist
            elseif (dist.eq.0.0) then
c             same location as last line - don't repeat it
            else
              if     (dist.gt.distmax) then
                 write(21,*)
              endif
              write(21,'(a)') trim(cline)
*             write(21,'(a,1pe20.6)') trim(cline),dist
            endif
          endif !skip_old:else
        endif !skip_new:else
      enddo
  100 continue
      close(21)
      end
      real*4 function spherdist(lon1,lat1,lon2,lat2)
      implicit none
      real, intent(in) :: lon1,lat1,lon2,lat2 ! Pos. in degrees
c
c --- ------------------------------------------------
c --- Computes the distance between geo. pos.
c --- lon1,lat1 and lon2,lat2.
c --- input is in degrees.
c
c --- output is real*4 for better global consistancy,
c --- by truncating double precision roundoff errors.
c --- real*4 is not in f90, but is widely supported.
c
c --- Based on m_spherdist.F90 from Geir Evanson.
c --- ------------------------------------------------
c
      double precision, parameter :: invradian=0.017453292d0
      double precision, parameter ::    rearth=6371001.0d0  ! Radius of earth
c
      double precision  dlon1,dlon2
      double precision  rlon1,rlat1,rlon2,rlat2           ! Pos. in radians
      double precision  x1,y1,z1,x2,y2,z2                 ! Cartesian position
      double precision  dr                                ! Arc length
c
c     ensure that spherdist(ax,ay,bx,by) == spherdist(bx,by,ax,ay)
c
      if     (lon1.eq.lon2 .and. lat1.eq.lat2) then
        spherdist=0.0
        return
      endif
c
      dlon1 = lon1
      dlon1 = mod(dlon1,360.d0)
      if     (dlon1.lt.0.d0) then
        dlon1 = dlon1 + 360.d0
      endif
      dlon2 = lon2
      dlon2 = mod(dlon2,360.d0)
      if     (dlon2.lt.0.d0) then
        dlon2 = dlon2 + 360.d0
      endif
      if     (lat1.lt.lat2) then
        rlon1=dlon1*invradian            !lon1 in rad
        rlat1=(90.d0-lat1)*invradian     !90-lat1 in rad
        rlon2=dlon2*invradian            !lon2 in rad
        rlat2=(90.d0-lat2)*invradian     !90-lat2 in rad
      elseif (lat1.eq.lat2 .and. dlon1.le.dlon2) then
        rlon1=dlon1*invradian            !lon1 in rad
        rlat1=(90.d0-lat1)*invradian     !90-lat1 in rad
        rlon2=dlon2*invradian            !lon2 in rad
        rlat2=(90.d0-lat2)*invradian     !90-lat2 in rad
      else
        rlon2=dlon1*invradian            !lon1 in rad
        rlat2=(90.d0-lat1)*invradian     !90-lat1 in rad
        rlon1=dlon2*invradian            !lon2 in rad
        rlat1=(90.d0-lat2)*invradian     !90-lat2 in rad
      endif
c
      x1= sin(rlat1)*cos(rlon1)        !x,y,z of pos 1.
      y1= sin(rlat1)*sin(rlon1)
      z1= cos(rlat1)
c
      x2= sin(rlat2)*cos(rlon2)        !x,y,z of pos 2.
      y2= sin(rlat2)*sin(rlon2)
      z2= cos(rlat2)
c
      dr=acos(min(1.d0,x1*x2+y1*y2+z1*z2))  ! Arc length
c
      spherdist=dr*rearth
c
      end function spherdist


PURE FUNCTION QUAD(X0, N)
 IMPLICIT NONE
 INTEGER, PARAMETER :: DP=KIND(0.d0)
 REAL(dp), INTENT(IN) :: X0
 REAL(dp) :: QUAD
 INTEGER :: I
 INTEGER, INTENT(IN) :: N
 QUAD = X0
 DO I = 1, N - 1
  QUAD = 4.0_dp * QUAD * real(1.0_dp - QUAD, dp)
 END DO
 RETURN
END FUNCTION QUAD

PROGRAM MAIN
 IMPLICIT NONE
 INTEGER, PARAMETER :: DP=KIND(0.d0)
 REAL(dp) :: START, FINISH, X, QUAD
 INTEGER :: N
 N = 10000000
 X = QUAD(0.2_dp, 10)
 CALL CPU_TIME(START)
 X = QUAD(0.2_dp, N)
 CALL CPU_TIME(FINISH)
 PRINT *,'last val = ', X
 PRINT *,'elapsed time = ', FINISH-START
END PROGRAM MAIN


*DECK QAWSE
      SUBROUTINE QAWSE (F, A, B, ALFA, BETA, INTEGR, EPSABS, EPSREL,
     +   LIMIT, RESULT, ABSERR, NEVAL, IER, ALIST, BLIST, RLIST, ELIST,
     +   IORD, LAST)
C***BEGIN PROLOGUE  QAWSE
C***PURPOSE  The routine calculates an approximation result to a given
C            definite integral I = Integral of F*W over (A,B),
C            (where W shows a singular behaviour at the end points,
C            see parameter INTEGR).
C            Hopefully satisfying following claim for accuracy
C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C***LIBRARY   SLATEC (QUADPACK)
C***CATEGORY  H2A2A1
C***TYPE      SINGLE PRECISION (QAWSE-S, DQAWSE-D)
C***KEYWORDS  ALGEBRAIC-LOGARITHMIC END POINT SINGULARITIES,
C             AUTOMATIC INTEGRATOR, CLENSHAW-CURTIS METHOD, QUADPACK,
C             QUADRATURE, SPECIAL-PURPOSE
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***DESCRIPTION
C
C        Integration of functions having algebraico-logarithmic
C        end point singularities
C        Standard fortran subroutine
C        Real version
C
C        PARAMETERS
C         ON ENTRY
C            F      - Real
C                     Function subprogram defining the integrand
C                     function F(X). The actual name for F needs to be
C                     declared E X T E R N A L in the driver program.
C
C            A      - Real
C                     Lower limit of integration
C
C            B      - Real
C                     Upper limit of integration, B.GT.A
C                     If B.LE.A, the routine will end with IER = 6.
C
C            ALFA   - Real
C                     Parameter in the WEIGHT function, ALFA.GT.(-1)
C                     If ALFA.LE.(-1), the routine will end with
C                     IER = 6.
C
C            BETA   - Real
C                     Parameter in the WEIGHT function, BETA.GT.(-1)
C                     If BETA.LE.(-1), the routine will end with
C                     IER = 6.
C
C            INTEGR - Integer
C                     Indicates which WEIGHT function is to be used
C                     = 1  (X-A)**ALFA*(B-X)**BETA
C                     = 2  (X-A)**ALFA*(B-X)**BETA*LOG(X-A)
C                     = 3  (X-A)**ALFA*(B-X)**BETA*LOG(B-X)
C                     = 4  (X-A)**ALFA*(B-X)**BETA*LOG(X-A)*LOG(B-X)
C                     If INTEGR.LT.1 or INTEGR.GT.4, the routine
C                     will end with IER = 6.
C
C            EPSABS - Real
C                     Absolute accuracy requested
C            EPSREL - Real
C                     Relative accuracy requested
C                     If  EPSABS.LE.0
C                     and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     the routine will end with IER = 6.
C
C            LIMIT  - Integer
C                     Gives an upper bound on the number of subintervals
C                     in the partition of (A,B), LIMIT.GE.2
C                     If LIMIT.LT.2, the routine will end with IER = 6.
C
C         ON RETURN
C            RESULT - Real
C                     Approximation to the integral
C
C            ABSERR - Real
C                     Estimate of the modulus of the absolute error,
C                     which should equal or exceed ABS(I-RESULT)
C
C            NEVAL  - Integer
C                     Number of integrand evaluations
C
C            IER    - Integer
C                     IER = 0 Normal and reliable termination of the
C                             routine. It is assumed that the requested
C                             accuracy has been achieved.
C                     IER.GT.0 Abnormal termination of the routine
C                             the estimates for the integral and error
C                             are less reliable. It is assumed that the
C                             requested accuracy has not been achieved.
C            ERROR MESSAGES
C                         = 1 Maximum number of subdivisions allowed
C                             has been achieved. One can allow more
C                             subdivisions by increasing the value of
C                             LIMIT. However, if this yields no
C                             improvement, it is advised to analyze the
C                             integrand in order to determine the
C                             integration difficulties which prevent the
C                             requested tolerance from being achieved.
C                             In case of a jump DISCONTINUITY or a local
C                             SINGULARITY of algebraico-logarithmic type
C                             at one or more interior points of the
C                             integration range, one should proceed by
C                             splitting up the interval at these
C                             points and calling the integrator on the
C                             subranges.
C                         = 2 The occurrence of roundoff error is
C                             detected, which prevents the requested
C                             tolerance from being achieved.
C                         = 3 Extremely bad integrand behaviour occurs
C                             at some points of the integration
C                             interval.
C                         = 6 The input is invalid, because
C                             B.LE.A or ALFA.LE.(-1) or BETA.LE.(-1), or
C                             INTEGR.LT.1 or INTEGR.GT.4, or
C                             (EPSABS.LE.0 and
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                             or LIMIT.LT.2.
C                             RESULT, ABSERR, NEVAL, RLIST(1), ELIST(1),
C                             IORD(1) and LAST are set to zero. ALIST(1)
C                             and BLIST(1) are set to A and B
C                             respectively.
C
C            ALIST  - Real
C                     Vector of dimension at least LIMIT, the first
C                      LAST  elements of which are the left
C                     end points of the subintervals in the partition
C                     of the given integration range (A,B)
C
C            BLIST  - Real
C                     Vector of dimension at least LIMIT, the first
C                      LAST  elements of which are the right
C                     end points of the subintervals in the partition
C                     of the given integration range (A,B)
C
C            RLIST  - Real
C                     Vector of dimension at least LIMIT, the first
C                      LAST  elements of which are the integral
C                     approximations on the subintervals
C
C            ELIST  - Real
C                     Vector of dimension at least LIMIT, the first
C                      LAST  elements of which are the moduli of the
C                     absolute error estimates on the subintervals
C
C            IORD   - Integer
C                     Vector of dimension at least LIMIT, the first K
C                     of which are pointers to the error
C                     estimates over the subintervals, so that
C                     ELIST(IORD(1)), ..., ELIST(IORD(K)) with K = LAST
C                     If LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST
C                     otherwise form a decreasing sequence
C
C            LAST   - Integer
C                     Number of subintervals actually produced in
C                     the subdivision process
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  QC25S, QMOMO, QPSRT, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   800101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  QAWSE
C
      REAL A,ABSERR,ALFA,ALIST,AREA,AREA1,AREA12,
     1  AREA2,A1,A2,B,BETA,BLIST,B1,B2,CENTRE,
     2  R1MACH,ELIST,EPMACH,EPSABS,EPSREL,ERRBND,ERRMAX,
     3  ERROR1,ERRO12,ERROR2,ERRSUM,F,RESAS1,RESAS2,RESULT,RG,RH,RI,RJ,
     4  RLIST,UFLOW
      INTEGER IER,INTEGR,IORD,IROFF1,IROFF2,K,LAST,
     1  LIMIT,MAXERR,NEV,NEVAL,NRMAX
C
      EXTERNAL F
C
      DIMENSION ALIST(*),BLIST(*),RLIST(*),ELIST(*),
     1  IORD(*),RI(25),RJ(25),RH(25),RG(25)
C
C            LIST OF MAJOR VARIABLES
C            -----------------------
C
C           ALIST     - LIST OF LEFT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           BLIST     - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS
C                       CONSIDERED UP TO NOW
C           RLIST(I)  - APPROXIMATION TO THE INTEGRAL OVER
C                       (ALIST(I),BLIST(I))
C           ELIST(I)  - ERROR ESTIMATE APPLYING TO RLIST(I)
C           MAXERR    - POINTER TO THE INTERVAL WITH LARGEST
C                       ERROR ESTIMATE
C           ERRMAX    - ELIST(MAXERR)
C           AREA      - SUM OF THE INTEGRALS OVER THE SUBINTERVALS
C           ERRSUM    - SUM OF THE ERRORS OVER THE SUBINTERVALS
C           ERRBND    - REQUESTED ACCURACY MAX(EPSABS,EPSREL*
C                       ABS(RESULT))
C           *****1    - VARIABLE FOR THE LEFT SUBINTERVAL
C           *****2    - VARIABLE FOR THE RIGHT SUBINTERVAL
C           LAST      - INDEX FOR SUBDIVISION
C
C
C            MACHINE DEPENDENT CONSTANTS
C            ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C
C***FIRST EXECUTABLE STATEMENT  QAWSE
      EPMACH = R1MACH(4)
      UFLOW = R1MACH(1)
C
C           TEST ON VALIDITY OF PARAMETERS
C           ------------------------------
C
      IER = 6
      NEVAL = 0
      LAST = 0
      RLIST(1) = 0.0E+00
      ELIST(1) = 0.0E+00
      IORD(1) = 0
      RESULT = 0.0E+00
      ABSERR = 0.0E+00
      IF (B.LE.A.OR.(EPSABS.EQ.0.0E+00.AND.
     1    EPSREL.LT.MAX(0.5E+02*EPMACH,0.5E-14)).OR.ALFA.LE.(-0.1E+01)
     2    .OR.BETA.LE.(-0.1E+01).OR.INTEGR.LT.1.OR.INTEGR.GT.4.OR.
     3    LIMIT.LT.2) GO TO 999
      IER = 0
C
C           COMPUTE THE MODIFIED CHEBYSHEV MOMENTS.
C
      CALL QMOMO(ALFA,BETA,RI,RJ,RG,RH,INTEGR)
C
C           INTEGRATE OVER THE INTERVALS (A,(A+B)/2)
C           AND ((A+B)/2,B).
C
      CENTRE = 0.5E+00*(B+A)
      CALL QC25S(F,A,B,A,CENTRE,ALFA,BETA,RI,RJ,RG,RH,AREA1,
     1  ERROR1,RESAS1,INTEGR,NEV)
      NEVAL = NEV
      CALL QC25S(F,A,B,CENTRE,B,ALFA,BETA,RI,RJ,RG,RH,AREA2,
     1  ERROR2,RESAS2,INTEGR,NEV)
      LAST = 2
      NEVAL = NEVAL+NEV
      RESULT = AREA1+AREA2
      ABSERR = ERROR1+ERROR2
C
C           TEST ON ACCURACY.
C
      ERRBND = MAX(EPSABS,EPSREL*ABS(RESULT))
C
C           INITIALIZATION
C           --------------
C
      IF(ERROR2.GT.ERROR1) GO TO 10
      ALIST(1) = A
      ALIST(2) = CENTRE
      BLIST(1) = CENTRE
      BLIST(2) = B
      RLIST(1) = AREA1
      RLIST(2) = AREA2
      ELIST(1) = ERROR1
      ELIST(2) = ERROR2
      GO TO 20
   10 ALIST(1) = CENTRE
      ALIST(2) = A
      BLIST(1) = B
      BLIST(2) = CENTRE
      RLIST(1) = AREA2
      RLIST(2) = AREA1
      ELIST(1) = ERROR2
      ELIST(2) = ERROR1
   20 IORD(1) = 1
      IORD(2) = 2
      IF(LIMIT.EQ.2) IER = 1
      IF(ABSERR.LE.ERRBND.OR.IER.EQ.1) GO TO 999
      ERRMAX = ELIST(1)
      MAXERR = 1
      NRMAX = 1
      AREA = RESULT
      ERRSUM = ABSERR
      IROFF1 = 0
      IROFF2 = 0
C
C            MAIN DO-LOOP
C            ------------
C
      DO 60 LAST = 3,LIMIT
C
C           BISECT THE SUBINTERVAL WITH LARGEST ERROR ESTIMATE.
C
        A1 = ALIST(MAXERR)
        B1 = 0.5E+00*(ALIST(MAXERR)+BLIST(MAXERR))
        A2 = B1
        B2 = BLIST(MAXERR)
C
        CALL QC25S(F,A,B,A1,B1,ALFA,BETA,RI,RJ,RG,RH,AREA1,
     1  ERROR1,RESAS1,INTEGR,NEV)
        NEVAL = NEVAL+NEV
        CALL QC25S(F,A,B,A2,B2,ALFA,BETA,RI,RJ,RG,RH,AREA2,
     1  ERROR2,RESAS2,INTEGR,NEV)
        NEVAL = NEVAL+NEV
C
C           IMPROVE PREVIOUS APPROXIMATIONS INTEGRAL AND ERROR
C           AND TEST FOR ACCURACY.
C
        AREA12 = AREA1+AREA2
        ERRO12 = ERROR1+ERROR2
        ERRSUM = ERRSUM+ERRO12-ERRMAX
        AREA = AREA+AREA12-RLIST(MAXERR)
        IF(A.EQ.A1.OR.B.EQ.B2) GO TO 30
        IF(RESAS1.EQ.ERROR1.OR.RESAS2.EQ.ERROR2) GO TO 30
C
C           TEST FOR ROUNDOFF ERROR.
C
        IF(ABS(RLIST(MAXERR)-AREA12).LT.0.1E-04*ABS(AREA12)
     1  .AND.ERRO12.GE.0.99E+00*ERRMAX) IROFF1 = IROFF1+1
        IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF2 = IROFF2+1
   30   RLIST(MAXERR) = AREA1
        RLIST(LAST) = AREA2
C
C           TEST ON ACCURACY.
C
        ERRBND = MAX(EPSABS,EPSREL*ABS(AREA))
        IF(ERRSUM.LE.ERRBND) GO TO 35
C
C           SET ERROR FLAG IN THE CASE THAT THE NUMBER OF INTERVAL
C           BISECTIONS EXCEEDS LIMIT.
C
        IF(LAST.EQ.LIMIT) IER = 1
C
C
C           SET ERROR FLAG IN THE CASE OF ROUNDOFF ERROR.
C
        IF(IROFF1.GE.6.OR.IROFF2.GE.20) IER = 2
C
C           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
C           AT INTERIOR POINTS OF INTEGRATION RANGE.
C
        IF(MAX(ABS(A1),ABS(B2)).LE.(0.1E+01+0.1E+03*EPMACH)*
     1  (ABS(A2)+0.1E+04*UFLOW)) IER = 3
C
C           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.
C
   35   IF(ERROR2.GT.ERROR1) GO TO 40
        ALIST(LAST) = A2
        BLIST(MAXERR) = B1
        BLIST(LAST) = B2
        ELIST(MAXERR) = ERROR1
        ELIST(LAST) = ERROR2
        GO TO 50
   40   ALIST(MAXERR) = A2
        ALIST(LAST) = A1
        BLIST(LAST) = B1
        RLIST(MAXERR) = AREA2
        RLIST(LAST) = AREA1
        ELIST(MAXERR) = ERROR2
        ELIST(LAST) = ERROR1
C
C           CALL SUBROUTINE QPSRT TO MAINTAIN THE DESCENDING ORDERING
C           IN THE LIST OF ERROR ESTIMATES AND SELECT THE
C           SUBINTERVAL WITH LARGEST ERROR ESTIMATE (TO BE
C           BISECTED NEXT).
C
   50   CALL QPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX)
C ***JUMP OUT OF DO-LOOP
        IF (IER.NE.0.OR.ERRSUM.LE.ERRBND) GO TO 70
   60 CONTINUE
C
C           COMPUTE FINAL RESULT.
C           ---------------------
C
   70 RESULT = 0.0E+00
      DO 80 K=1,LAST
        RESULT = RESULT+RLIST(K)
   80 CONTINUE
      ABSERR = ERRSUM
  999 RETURN
      END


! This program will smooth a set of data (read in from a file) onto a grid
!  with a size that depends on the desired resolution. The file is expected
!  to be a 2-column data (x,y) with values in the range [0,1]. Values out
!  of that range will not be included in the smoothing (and may cause a
!  segmentation fault near the boundaries).

! preprocessor directives (quartic = 1, epan = 2, gaussian = 3, tricubic = 4)
#define WEIGHT 1

program gridding
    implicit none
    integer, parameter :: wp = selected_real_kind(15,307)
    real(wp) :: E
    real(wp), allocatable, dimension(:,:) :: Map
    real(wp), allocatable, dimension(:) :: x, y, xgrid, ygrid
    real(wp), dimension(10) :: resolution = -1.0
    real(wp) :: h, dij, u, v, xp, yp, thick, radius
    integer :: i, j, k, n, ii, jj, numpart, numgrid, ierr, lun, fileread, partStep, numres
    character(len=100) :: filename

    lun = 10

! open input file & error check
    namelist / particles / filename, resolution
    open(unit=lun,file="init.nml",iostat=ierr)
    if(ierr/=0) then
        print*,"Unable to open 'init.nml', does it exist?"
        stop
    endif
    read(lun,nml=particles,iostat=ierr)
    if(ierr/=0) then
       print *,"Unable to read 'particles' namelist, does it exist in file?"
    endif
! error check resolution
    if(any(resolution > 0.5)) then
       print *,"Error: resolution above 0.5 causes segmentation fault error"
       stop
    endif
    close(lun)

! open file with particle position data
    open(unit=lun,file=filename,iostat=ierr)
    if(ierr/=0) then
       print *,"Error, unable to read file '",filename,"'"
       stop
    endif

! count number of particles
    i=1
    do
       read(lun,*,iostat=ierr) xp,yp,E
       if(ierr/=0) exit
       i = i +1
    enddo
    rewind(lun)
    numpart = i-1

! allocate particle positions and then read them in
    allocate(x(numpart),y(numpart))
    do i=1,numpart
       read(lun,*) x(i),y(i)
    enddo

    numres = count(resolution > 0.0)
! run through resolutions
    do k=1,numres
        h = resolution(k)
        numgrid = int(2d0/h)
! allocate grid space
        print '(a,f8.5,a,i0,a)',"Running h=",h," --> grid size of ",numgrid,"^2"
        call AllocateGrid(numgrid,Map,xgrid,ygrid)

! step size (set > 1  for more diffuse display)
        partStep = 1

! loop through the particles from the file
        do n=1,numpart,partStep
! find the closest cells to the particle position
            xp = x(n); yp = y(n)
            ii = FindBox(numgrid,xp,xgrid)
            jj = FindBox(numgrid,yp,ygrid)

! loop through the adjacent cells of centroid (ii,jj) and measure "leakage"
            do j=jj-1,jj+1
                do i=ii-1,ii+1
                    u = xp - xgrid(i)
                    v = yp - ygrid(j)
                    dij = sqrt(u*u + v*v)
                    if(dij <= h) then
                        map(i,j) = map(i,j) + kernel(dij,h)
                    endif
                enddo !- i
            enddo !- j
        enddo !- n

! write the map to a file
        call WriteOut(numgrid,xgrid,ygrid,map,h)

    enddo !- k

 contains

    !> @brief allocate grid positions and map
    subroutine AllocateGrid(n,M,x,y)
        integer, intent(in) :: n
        real(wp), allocatable,intent(out) :: M(:,:), x(:), y(:)
        real(wp) :: xi, yi, dx
        integer :: ierr, i

! deallocate if necessary
        if(allocated(M)) deallocate(M)
        if(allocated(x)) deallocate(x)
        if(allocated(y)) deallocate(y)
        allocate(M(n,n),x(n),y(n),stat=ierr)
        if(ierr/=0) then
            print *,"unable to allocate M,x,or y"
            stop
        endif

        xi = -0.5
        yi = -0.5
        dx = 2.0/real(n+1)
        do i=1,n
            x(i) = xi + (real(i) - 0.5)*dx
            y(i) = yi + (real(i) - 0.5)*dx
        enddo
        M(:,:) = 0.0
    end subroutine AllocateGrid

    !> @brief determine closest cell to point
    pure function FindBox(n,rp,rg) result(i)
        integer, intent(in) :: n
        real(wp), intent(in) :: rp
        real(wp), dimension(n), intent(in) :: rg
        integer:: i
        real(wp) :: r, rmin
        integer :: j,jcell
        rmin = 100d0
        do j=1,n
            r = abs(rp - rg(j))
            if(r < rmin) then
                rmin = r
                jcell = j
            endif
        enddo
        i = jcell
    end function FindBox

    !> @brief tricubic interpolation
    !! @info 0.864... is 70/81
    real(wp) function kernel(d,h)
        real(wp), intent(in) :: d, h
        real(wp) :: u, coef, a, b
        u = d/h
#if WEIGHT == 1
! Quartic biweight
        a = 0.9375
        coef = a/h
        b = 1d0 - u*u
        kernel = coef*b*b
#elif WEIGHT == 2
! Epanechnikov
        a = 0.75
        coef = a/h
        kernel = coef*(1d0 - t*t/5d0)
#elif WEIGHT == 3
! Gaussian
        a = 0.39894228 ! 1/sqrt(2*pi)
        coef = a/h
        kernel = coef*exp(-0.5*t*t)
#elif WEIGHT == 4
! Tricubic
        a = 0.864197531
        coef = a/h
        b = 1d0 - u*u*u
        kernel = coef*b*b*b
#else
#error "Unknown kernel"
#endif
    end function kernel

    !> @brief write data to file
    subroutine WriteOut(ng,x,y,M,h)
        integer, intent(in) :: ng
        real(wp), dimension(ng),intent(in) :: x,y
        real(wp), dimension(ng,ng), intent(in) :: M
        real(wp), intent(in) :: h
        integer :: i,j, ierr, lun
        character(len=80) :: filename
        character(len=8) :: nchar

        write(nchar,'(f8.5)') h
        filename = 'grid_'//trim(adjustl(nchar))//'.dat'

        lun = 10

! open output file & error check
        open(unit=lun,file=trim(filename),iostat=ierr)
        if(ierr/=0) then
            print *,"Error:unable to open file",filename
            stop
        endif

! this writes to a gnuplot-readable format
        do j=1,ng
            do i=1,ng
                write(lun,*) x(i),y(j),M(i,j)
            enddo
            write(lun,*) " "
        enddo
        close(lun)
    end subroutine WriteOut

end program gridding


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE PTSNRM( PLAPTS, INPT,  CUTPT, CUTNRM , IERR)
C=======================================================================

C   --*** PTRNRM *** (MESH) Turns three point plane to point-normal form
C   --   Written by Ray J. Meyers 29 May, 1990
C   --
C   -- Given three non-colinear points, returns a description of the plane
C   -- consisting of a point on the plane and a normal vector to the plane.
C   --
C   --Parameters:
C   --   PLAPTS - IN - the 3 points defining the cutting plane;
C   --   INPT - IN - a point in the mesh, ie, on the opposite side
C                    from the cutting plane normal
C   --   CUTPT - OUT - a point on the cutting plane;
C   --   CUTNRM - OUT - the normal to the cutting plane;
C   --   IERR - OUT - non-zero if the input points are colinear (no plane
C                     defined)

      REAL PLAPTS(3,3)
      REAL INPT(3)
      REAL CUTPT(3)
      REAL CUTNRM(3)
      INTEGER IERR
      REAL VEC1(3), VEC2(3)
      REAL TOL, DOT

C DEFINE TWO VECTORS IN THE PLANE : VEC1 = P1-P2, VEC2 = P3-P2

      VEC1(1) = PLAPTS(1,1) - PLAPTS(1,2)
      VEC1(2) = PLAPTS(2,1) - PLAPTS(2,2)
      VEC1(3) = PLAPTS(3,1) - PLAPTS(3,2)
      VEC2(1) = PLAPTS(1,3) - PLAPTS(1,2)
      VEC2(2) = PLAPTS(2,3) - PLAPTS(2,2)
      VEC2(3) = PLAPTS(3,3) - PLAPTS(3,2)

C DEFINE A TOLERANCE BASED ON THE LENGTH OF  VEC1

      TOL = 1E-06 * AMAX1 ( VEC1(1), VEC1(2), VEC1(3) )

C TAKE THE CROSS PRODUCT OF VEC1 AND VEC2 AS THE NORMAL OF THE PLANE AND
C NORMALIZE

      CUTNRM(1) = VEC1(2)*VEC2(3) - VEC1(3)*VEC2(2)
      CUTNRM(2) = VEC1(3)*VEC2(1) - VEC1(1)*VEC2(3)
      CUTNRM(3) = VEC1(1)*VEC2(2) - VEC1(2)*VEC2(1)

      DIST = SQRT( CUTNRM(1)*CUTNRM(1) + CUTNRM(2)*CUTNRM(2) +
     $             CUTNRM(3)*CUTNRM(3) )
      CUTNRM(1) = CUTNRM(1)/DIST
      CUTNRM(2) = CUTNRM(2)/DIST
      CUTNRM(3) = CUTNRM(3)/DIST

C IF THE NORMAL IS (0,0,0), THE ORIGINAL POINTS WERE COLINEAR

      IF( ABS(CUTNRM(1)) .LT. TOL .AND. ABS(CUTNRM(2)) .LT. TOL
     $    .AND. ABS(CUTNRM(3)) .LT. TOL) THEN
          CALL PRTERR ('CMDERR', 'Points do not define a plane')
          IERR = 1
      ELSE
          IERR = 0

C USE THE SECOND INPUT POINT AS THE CHOSEN CUTPT

          CUTPT(1) = PLAPTS(1,2)
          CUTPT(2) = PLAPTS(2,2)
          CUTPT(3) = PLAPTS(3,2)

C CHECK THE INPT TO SEE IF THE NORMAL IS THE CORRECT SENSE

          VEC1(1) = INPT(1) - CUTPT(1)
          VEC1(2) = INPT(2) - CUTPT(2)
          VEC1(3) = INPT(3) - CUTPT(3)
          DOT = VEC1(1)*CUTNRM(1) + VEC1(2)*CUTNRM(2) +
     $          VEC1(3)*CUTNRM(3)
          IF(DOT .GT. 0) THEN
             CUTNRM(1) = -CUTNRM(1)
             CUTNRM(2) = -CUTNRM(2)
             CUTNRM(3) = -CUTNRM(3)
          END IF
      END IF

      RETURN
      END