        subroutine iddp_svd(lw,eps,m,n,a,krank,iu,iv,is,w,ier)
c
c       constructs a rank-krank SVD  U Sigma V^T  approximating a
c       to precision eps, where U is an m x krank matrix whose
c       columns are orthonormal, V is an n x krank matrix whose
c       columns are orthonormal, and Sigma is a diagonal krank x krank
c       matrix whose entries are all nonnegative.
c       The entries of U are stored in w, starting at w(iu);
c       the entries of V are stored in w, starting at w(iv).
c       The diagonal entries of Sigma are stored in w,
c       starting at w(is). This routine combines a QR code
c       (which is based on plane/Householder reflections)
c       with the LAPACK routine dgesdd.
c
c       input:
c       lw -- maximum usable length of w (in real*8 elements)
c       eps -- precision to which the SVD approximates a
c       m -- first dimension of a and u
c       n -- second dimension of a, and first dimension of v
c       a -- matrix to be SVD'd
c
c       output:
c       krank -- rank of the approximation to a
c       iu -- index in w of the first entry of the matrix
c             of orthonormal left singular vectors of a
c       iv -- index in w of the first entry of the matrix
c             of orthonormal right singular vectors of a
c       is -- index in w of the first entry of the array
c             of singular values of a
c       w -- array containing the singular values and singular vectors
c            of a; w doubles as a work array, and so must be at least
c            (krank+1)*(m+2*n+9)+8*min(m,n)+15*krank**2
c            real*8 elements long, where krank is the rank
c            output by the present routine
c       ier -- 0 when the routine terminates successfully;
c              -1000 when lw is too small;
c              other nonzero values when dgesdd bombs
c
c       _N.B._: This routine destroys a. Also, please beware that
c               the source code for this routine could be clearer.
c               w must be at least
c               (krank+1)*(m+2*n+9)+8*min(m,n)+15*krank**2
c               real*8 elements long, where krank is the rank
c               output by the present routine.
c
        implicit none
        character*1 jobz
        integer m,n,k,krank,iftranspose,ldr,ldu,ldvt,lwork,
     1          info,j,ier,io,iu,iv,is,ivi,isi,lw,lu,lv,ls
        real*8 a(m,n),w(*),eps
c
c
        io = 8*min(m,n)
c
c
        ier = 0
c
c
c       Compute a pivoted QR decomposition of a.
c
        call iddp_qrpiv(eps,m,n,a,krank,w,w(io+1))
c
c
        if(krank .gt. 0) then
c
c
c         Extract R from the QR decomposition.
c
          call idd_retriever(m,n,a,krank,w(io+1))
c
c
c         Rearrange R according to ind (which is stored in w).
c
          call idd_permuter(krank,w,krank,n,w(io+1))
c
c
c         Use LAPACK to SVD R,
c         storing the krank (krank x 1) left singular vectors
c         in w(io+krank*n+1 : io+krank*n+krank*krank).
c
          jobz = 'S'
          ldr = krank
          lwork = 2*(3*krank**2+n+4*krank**2+4*krank)
          ldu = krank
          ldvt = krank
c
          ivi = io+krank*n+krank*krank+lwork+1
          lv = n*krank
c
          isi = ivi+lv
          ls = krank
c
          if(lw .lt. isi+ls+m*krank-1) then
            ier = -1000
            return
          endif
c
          call dgesdd(jobz,krank,n,w(io+1),ldr,w(isi),w(io+krank*n+1),
     1                ldu,w(ivi),ldvt,w(io+krank*n+krank*krank+1),
     2                lwork,w,info)
c
          if(info .ne. 0) then
            ier = info
            return
          endif
c
c
c         Transpose w(ivi:ivi+lv-1) to obtain V.
c
          iv = 1
          call idd_transer(krank,n,w(ivi),w(iv))
c
c
c         Copy w(isi:isi+ls-1) into w(is:is+ls-1).
c
          is = iv+lv
c
          do k = 1,ls
            w(is+k-1) = w(isi+k-1)
          enddo ! k
c
c
c         Multiply the U from R from the left by Q to obtain the U
c         for A.
c
          iu = is+ls
          lu = m*krank
c
          do k = 1,krank
c
            do j = 1,krank
              w(iu-1+j+krank*(k-1)) = w(io+krank*n+j+krank*(k-1))
            enddo ! j
c
          enddo ! k
c
          do k = krank,1,-1
c
            do j = m,krank+1,-1
              w(iu-1+j+m*(k-1)) = 0
            enddo ! j
c
            do j = krank,1,-1
              w(iu-1+j+m*(k-1)) = w(iu-1+j+krank*(k-1))
            enddo ! j
c
          enddo ! k
c
          iftranspose = 0
          call idd_qmatmat(iftranspose,m,n,a,krank,krank,w(iu),
     1                     w(iu+lu+1))
c
c
        endif ! krank .gt. 0
c
c
        return
        end
c
c
c
c


subroutine nif_growth(PO4,PAR,temp,tau,mu,theta)
use bio_MOD, only : params, iKPnif, TEMPBOL,Ep
implicit none
real, intent(in)  :: PO4, PAR, temp,tau
real, intent(out) :: mu, theta
real, parameter   :: tau_crit = 0.062 !Critical wind stress (N m-2)
real, parameter   :: tem_crit = 24.75 !Critical temperature (ºC)
real, parameter   :: aI0      = 0.01  !Initial slope of the P-I curve
real, parameter   :: mumax    = 0.3   !Maximal growth rate of diazotrophs at 15 ºC
real, parameter   :: thetamin = 0.02, thetamax = 0.47

! Amplification factor
real :: ampl
real :: tf
real :: SI  ! Light limitation index
real :: Kpo4nih  = 0.05  !Half-saturation constant for PO4 uptake by nif

tf      = TEMPBOL(Ep,temp)
Kpo4nih = params(iKPnif)
! This subroutine follows Fennel et al. (2002) to incorporate PO4
! Diatroph growth rates depends on temperature, light, and wind stress
ampl = tanh(2.*(temp - tem_crit)) + 2.
!if (tau .le. tau_crit) then
   ampl = ampl/3.
!else
!   ampl = ampl/6.
!endif

!The light limitation index (SI)
! Unit of aI0: (W m-2)-1 d-1
SI    = 1d0 - exp(-aI0*PAR/mumax)
mu    = ampl*SI*PO4/(PO4+Kpo4nih)*mumax*tf

!if (mu < 0.) then
!   write(6,*) 'ampl = ', ampl
!   write(6,*) 'SI   = ', SI
!   write(6,*) 'LnoP = ', PO4/(PO4+Kpo4nih)
!   stop
!endif
theta = thetamin+mu/PAR/aI0*(thetamax-thetamin)   !Unit: gChl/molC
end subroutine


module parameters
    implicit none

    !! Problem Size
    !! NOTE: Pressure solver only works for hx==hy
    integer, parameter :: nnx = 100
    integer, parameter :: nny = 100
    real, parameter :: lx = 1.0
    real, parameter :: ly = 1.0
    real, parameter :: hx = lx/nnx
    real, parameter :: hy = ly/nny
    real, parameter :: hm = min(hx,hy)

    !! Flow Parameters
    real, parameter :: uvel = 4.0
    real, parameter :: dpg  = 2.00 ! works well for 10 turbines

    !! Time Step and TF
    real, parameter :: cfl = 0.5
    real, parameter :: dt = hm/(3*uvel)*cfl
    real, parameter :: tf = 4.0
    integer, parameter :: nts = tf/dt

    !! Pressure solver
    integer, parameter :: niter = 50

    !! Saving the files
    integer, parameter :: write_freq = 10000000
    character(*), parameter :: write_dir = './' ! make sure this exists

    !! Actuator disk setup
    integer, parameter :: ndisks = 20
    character (len=*), parameter :: adisk_fname = './adisk.txt' ! make sure this exists
    integer, parameter :: r = nnx/32
    real, parameter :: alpha = 0.5

    !! Usefull stuff
    real, parameter :: pi=3.14159

end module


      DOUBLE PRECISION FUNCTION slPA (HA, DEC, PHI)
*+
*     - - -
*      P A
*     - - -
*
*  HA, Dec to Parallactic Angle (double precision)
*
*  Given:
*     HA     d     hour angle in radians (geocentric apparent)
*     DEC    d     declination in radians (geocentric apparent)
*     PHI    d     observatory latitude in radians (geodetic)
*
*  The result is in the range -pi to +pi
*
*  Notes:
*
*  1)  The parallactic angle at a point in the sky is the position
*      angle of the vertical, i.e. the angle between the direction to
*      the pole and to the zenith.  In precise applications care must
*      be taken only to use geocentric apparent HA,Dec and to consider
*      separately the effects of atmospheric refraction and telescope
*      mount errors.
*
*  2)  At the pole a zero result is returned.
*
*  P.T.Wallace   Starlink   16 August 1994
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION HA,DEC,PHI

      DOUBLE PRECISION CP,SQSZ,CQSZ

      CP=COS(PHI)
      SQSZ=CP*SIN(HA)
      CQSZ=SIN(PHI)*COS(DEC)-CP*SIN(DEC)*COS(HA)
      IF (SQSZ.EQ.0D0.AND.CQSZ.EQ.0D0) CQSZ=1D0
      slPA=ATAN2(SQSZ,CQSZ)

      END


! ******************************************
! Integer function CalcH8NablaShape()
!
! IN:
! iElemType(integer): Element type (see hCommon.h)
! XYZ(float), XI(float), ETA(float), ZETA(float),
! B(float), DET(float)
!
! OUT:
! nDOFs(integer): Number of DOFs per element
! nProps(itneger): Number of properties per property type
!
! RETURNS:
! (integer): Number of nodes per element
!
! UPDATES:
! ---
!
! PURPOSE:
!    Evaluate the derivatives of the shape functions
!
! NOTES:
! ---
! ******************************************
Subroutine CalcH8NablaShape(fXi, fEta, fZeta, faDS)
	Implicit None

	Real, Intent(IN) :: fXi, fEta, fZeta
	Real, Intent(OUT) :: faDS(24)
	Real, Parameter :: fSq125 = 0.35355339059327376220042218105242
	Real fXiP, fEtaP, fZetaP, fXiM, fEtaM, fZetaM

! Main routine
	fXiP = (1D0 + fXi) * fSq125
	fEtaP = (1D0 + fEta) * fSq125
	fZetaP = (1D0 + fZeta) * fSq125
	fXiM = (1D0 - fXi) * fSq125
	fEtaM = (1D0 - fEta) * fSq125
	fZetaM = (1D0 - fZeta) * fSq125

! Calculation of natural coordinate derivatives of the shape functions
! Corresponding to XI
	faDS(1) = - fEtaM * fZetaM
	faDS(2) = - faDS(1)
	faDS(3) = fEtaP * fZetaM
	faDS(4) = - faDS(3)
	faDS(5) = - fEtaM * fZetaP
	faDS(6) = - faDS(5)
	faDS(7) = fEtaP * fZetaP
	faDS(8) = - faDS(7)
! Corresponding to ETA
    faDS(9) = - fXiM * fZetaM
    faDS(10) = - fXiP * fZetaM
    faDS(11) = - faDS(10)
    faDS(12) = - faDS(9)
	faDS(13) = - fXiM * fZetaP
	faDS(14) = - fXiP * fZetaP
	faDS(15) = - faDS(14)
	faDS(16) = - faDS(13)
! Corresponding to ZETA
	faDS(17) = - fXiM * fEtaM
	faDS(18) = - fXiP * fEtaM
	faDS(19) = - fXiP * fEtaP
	faDS(20) = - fXiM * fEtaP
	faDS(21) = - faDS(17)
	faDS(22) = - faDS(18)
	faDS(23) = - faDS(19)
	faDS(24) = - faDS(20)
End Subroutine

! ******************************************
! Integer function CalcShapeHexa8()
!
! IN:
! iElemType(integer): Element type (see hCommon.h)
!
! OUT:
! nDOFs(integer): Number of DOFs per element
! nProps(itneger): Number of properties per property type
!
! RETURNS:
! (integer): Number of nodes per element
!
! UPDATES:
! ---
!
! PURPOSE:
! Calculate shape functions for calculation of consistent mass matrix
!
! NOTES:
! ---
! ******************************************
Subroutine CalcH8Shape(fXi, fEta, fZeta, faS)
	Implicit None

	Real, Intent(IN) :: fXi, fEta, fZeta
	Real, Intent(OUT) :: faS(8)
	Real, Parameter :: fSqC125 = 0.5D0
	Real fXiP, fEtaP, fZetaP, fXiM, fEtaM, fZetaM

! Main routine
	fXiP = (1.0 + fXi) * fSqC125
	fEtaP = (1.0 + fEta) * fSqC125
	fZetaP = (1.0 + fZeta) * fSqC125
	fXiM = (1.0 - fXi) * fSqC125
	fEtaM = (1.0 - fEta) * fSqC125
	fZetaM = (1.0 - fZeta) * fSqC125

	faS(1) = fXiM * fEtaM * fZetaM
	faS(2) = fXiP * fEtaM * fZetaM
	faS(3) = fXiP * fEtaP * fZetaM
	faS(4) = fXiM * fEtaP * fZetaM
	faS(5) = fXiM * fEtaM * fZetaP
	faS(6) = fXiP * fEtaM * fZetaP
	faS(7) = fXiP * fEtaP * fZetaP
	faS(8) = fXiM * fEtaP * fZetaP
End Subroutine

! ******************************************
! Integer function CalcShapeHexa8()
!
! IN:
! iElemType(integer): Element type (see hCommon.h)
!
! OUT:
! nDOFs(integer): Number of DOFs per element
! nProps(itneger): Number of properties per property type
!
! RETURNS:
! (integer): Number of nodes per element
!
! UPDATES:
! ---
!
! PURPOSE:
! Calculate shape functions for calculation of consistent mass matrix
!
! NOTES:
! ---
! ******************************************
Integer Function CalcH8JDetJ(faXYZ, faDS, faJ, fDetJ)
	Implicit None
	Include 'hCommon.h'

	Real, Intent(IN) :: faXYZ(3, 8), faDS(24)
	Real, Intent(OUT) :: faJ(3, 3), fDetJ
	Real fDet1, fDet2, fDet3

! Main routine
	CalcH8JDetJ = iErrNegDet
! Compute the Jacobian at (XI, ETA, ZETA)
	faJ(1, 1) = faDS(1) * faXYZ(1, 1) + &
		faDS(2) * faXYZ(1, 2) + faDS(3) * faXYZ(1, 3) + &
		faDS(4) * faXYZ(1, 4) + faDS(5) * faXYZ(1, 5) + &
		faDS(6) * faXYZ(1, 6) + faDS(7) * faXYZ(1, 7) + &
		faDS(8) * faXYZ(1, 8)
	faJ(1, 2) = faDS(1) * faXYZ(2, 1) + &
		faDS(2) * faXYZ(2, 2) + faDS(3) * faXYZ(2, 3) + &
		faDS(4) * faXYZ(2, 4) + faDS(5) * faXYZ(2, 5) + &
		faDS(6) * faXYZ(2, 6) + faDS(7) * faXYZ(2, 7) + &
		faDS(8) * faXYZ(2, 8)
	faJ(1, 3) = faDS(1) * faXYZ(3, 1) + &
		faDS(2) * faXYZ(3, 2) + faDS(3) * faXYZ(3, 3) + &
		faDS(4) * faXYZ(3, 4) + faDS(5) * faXYZ(3, 5) + &
		faDS(6) * faXYZ(3, 6) + faDS(7) * faXYZ(3, 7) + &
		faDS(8) * faXYZ(3, 8)
	faJ(2, 1) = faDS(9) * faXYZ(1, 1) + &
		faDS(10) * faXYZ(1, 2) + faDS(11) * faXYZ(1, 3) + &
		faDS(12) * faXYZ(1, 4) + faDS(13) * faXYZ(1, 5) + &
		faDS(14) * faXYZ(1, 6) + faDS(15) * faXYZ(1, 7) + &
		faDS(16) * faXYZ(1, 8)
	faJ(2, 2) = faDS(9) * faXYZ(2, 1) + &
		faDS(10) * faXYZ(2, 2) + faDS(11) * faXYZ(2, 3) + &
		faDS(12) * faXYZ(2, 4) + faDS(13) * faXYZ(2, 5) + &
		faDS(14) * faXYZ(2, 6) + faDS(15) * faXYZ(2, 7) + &
		faDS(16) * faXYZ(2, 8)
	faJ(2, 3) = faDS(9) * faXYZ(3, 1) + &
		faDS(10) * faXYZ(3, 2) + faDS(11) * faXYZ(3, 3) + &
		faDS(12) * faXYZ(3, 4) + faDS(13) * faXYZ(3, 5) + &
		faDS(14) * faXYZ(3, 6) + faDS(15) * faXYZ(3, 7) + &
		faDS(16) * faXYZ(3, 8)
	faJ(3, 1) = faDS(17) * faXYZ(1, 1) + &
		faDS(18) * faXYZ(1, 2) + faDS(19) * faXYZ(1, 3) + &
		faDS(20) * faXYZ(1, 4) + faDS(21) * faXYZ(1, 5) + &
		faDS(22) * faXYZ(1, 6) + faDS(23) * faXYZ(1, 7) + &
		faDS(24) * faXYZ(1, 8)
	faJ(3, 2) = faDS(17) * faXYZ(2, 1) + &
		faDS(18) * faXYZ(2, 2) + faDS(19) * faXYZ(2, 3) + &
		faDS(20) * faXYZ(2, 4) + faDS(21) * faXYZ(2, 5) + &
		faDS(22) * faXYZ(2, 6) + faDS(23) * faXYZ(2, 7) + &
		faDS(24) * faXYZ(2, 8)
	faJ(3, 3) = faDS(17) * faXYZ(3, 1) + &
		faDS(18) * faXYZ(3, 2) + faDS(19) * faXYZ(3, 3) + &
		faDS(20) * faXYZ(3, 4) + faDS(21) * faXYZ(3, 5) + &
		faDS(22) * faXYZ(3, 6) + faDS(23) * faXYZ(3, 7) + &
		faDS(24) * faXYZ(3, 8)

	fDet1 = faJ(1, 1) * (faJ(2, 2) * faJ(3, 3) - faJ(3, 2) * faJ(2, 3))
	fDet2 = -faJ(1, 2) * (faJ(2, 1) * faJ(3, 3) - faJ(3, 1) * faJ(2, 3))
	fDet3 = faJ(1, 3) * (faJ(2, 1) * faJ(3, 2) - faJ(3, 1) * faJ(2, 2))
	fDetJ = fDet1 + fDet2 + fDet3
! Error if determinant is negative (return)
	If (fDetJ.LT.0.00000001) then
		Write(*, *) "Negative determinant (H8)"
		Return
	EndIf
	CalcH8JDetJ = iErrNoError
End Function

! ******************************************
! Integer function CalcShapeHexa8()
!
! IN:
! iElemType(integer): Element type (see hCommon.h)
!
! OUT:
! nDOFs(integer): Number of DOFs per element
! nProps(itneger): Number of properties per property type
!
! RETURNS:
! (integer): Number of nodes per element
!
! UPDATES:
! ---
!
! PURPOSE:
! Calculate shape functions for calculation of consistent mass matrix
!
! NOTES:
! ---
! ******************************************
Subroutine CalcH8B(fDetJ, faJ, faDS, faB)
	Implicit None

	Real, Intent(IN) :: fDetJ, faJ(3, 3), faDS(24)
	Real, Intent(OUT) :: faB(6, 24)
	Real faJInv(3, 3), fDetInv
!
! Main routine
! Calculate the Jacobian Inverse (faJInv)
	fDetInv = 1D0 / fDetJ
	faJInv(1, 1) = (faJ(2, 2) * faJ(3, 3) - faJ(3, 2) * faJ(2, 3)) * fDetInv
	faJInv(2, 1) = (faJ(3, 1) * faJ(2, 3) - faJ(2, 1) * faJ(3, 3)) * fDetInv
	faJInv(3, 1) = (faJ(2, 1) * faJ(3, 2) - faJ(3, 1) * faJ(2, 2)) * fDetInv
	faJInv(1, 2) = (faJ(3, 2) * faJ(1, 3) - faJ(1, 2) * faJ(3, 3)) * fDetInv
	faJInv(2, 2) = (faJ(1, 1) * faJ(3, 3) - faJ(3, 1) * faJ(1, 3)) * fDetInv
	faJInv(3, 2) = (faJ(3, 1) * faJ(1, 2) - faJ(3, 2) * faJ(1, 1)) * fDetInv
	faJInv(1, 3) = (faJ(1, 2) * faJ(2, 3) - faJ(2, 2) * faJ(1, 3)) * fDetInv
	faJInv(2, 3) = (faJ(2, 1) * faJ(1, 3) - faJ(1, 1) * faJ(2, 3)) * fDetInv
	faJInv(3, 3) = (faJ(1, 1) * faJ(2, 2) - faJ(2, 1) * faJ(1, 2)) * fDetInv

! Calculate the global derivative operator [faB]
	faB(1, 1) = faJInv(1, 1) * faDS(1) + faJInv(1, 2) * faDS(9) + faJInv(1, 3) * faDS(17)
	faB(1, 2) = 0D0
	faB(1, 3) = 0D0
	faB(1, 4) = faJInv(1, 1) * faDS(2) + faJInv(1, 2) * faDS(10) + faJInv(1, 3) * faDS(18)
	faB(1, 5) = 0D0
	faB(1, 6) = 0D0
	faB(1, 7) = faJInv(1, 1) * faDS(3) + faJInv(1, 2) * faDS(11) + faJInv(1, 3) * faDS(19)
	faB(1, 8) = 0D0
	faB(1, 9) = 0D0
	faB(1, 10) = faJInv(1, 1) * faDS(4) + faJInv(1, 2) * faDS(12) + faJInv(1, 3) * faDS(20)
	faB(1, 11) = 0D0
	faB(1, 12) = 0D0
	faB(1, 13) = faJInv(1, 1) * faDS(5) + faJInv(1, 2) * faDS(13) + faJInv(1, 3) * faDS(21)
	faB(1, 14) = 0D0
	faB(1, 15) = 0D0
	faB(1, 16) = faJInv(1, 1) * faDS(6) + faJInv(1, 2) * faDS(14) + faJInv(1, 3) * faDS(22)
	faB(1, 17) = 0D0
	faB(1, 18) = 0D0
	faB(1, 19) = faJInv(1, 1) * faDS(7) + faJInv(1, 2) * faDS(15) + faJInv(1, 3) * faDS(23)
	faB(1, 20) = 0D0
	faB(1, 21) = 0D0
	faB(1, 22) = faJInv(1, 1) * faDS(8) + faJInv(1, 2) * faDS(16) + faJInv(1, 3) * faDS(24)
	faB(1, 23) = 0D0
	faB(1, 24) = 0D0
	faB(2, 1) = 0D0
	faB(2, 2) = faJInv(2, 1) * faDS(1) + faJInv(2, 2) * faDS(9) + faJInv(2, 3) * faDS(17)
	faB(2, 3) = 0D0
	faB(2, 4) = 0D0
	faB(2, 5) = faJInv(2, 1) * faDS(2) + faJInv(2, 2) * faDS(10) + faJInv(2, 3) * faDS(18)
	faB(2, 6) = 0D0
	faB(2, 7) = 0D0
	faB(2, 8) = faJInv(2, 1) * faDS(3) + faJInv(2, 2) * faDS(11) + faJInv(2, 3) * faDS(19)
	faB(2, 9) = 0D0
	faB(2, 10) = 0D0
	faB(2, 11) = faJInv(2, 1) * faDS(4) + faJInv(2, 2) * faDS(12) + faJInv(2, 3) * faDS(20)
	faB(2, 12) = 0D0
	faB(2, 13) = 0D0
	faB(2, 14) = faJInv(2, 1) * faDS(5) + faJInv(2, 2) * faDS(13) + faJInv(2, 3) * faDS(21)
	faB(2, 15) = 0D0
	faB(2, 16) = 0D0
	faB(2, 17) = faJInv(2, 1) * faDS(6) + faJInv(2, 2) * faDS(14) + faJInv(2, 3) * faDS(22)
	faB(2, 18) = 0D0
	faB(2, 19) = 0D0
	faB(2, 20) = faJInv(2, 1) * faDS(7) + faJInv(2, 2) * faDS(15) + faJInv(2, 3) * faDS(23)
	faB(2, 21) = 0D0
	faB(2, 22) = 0D0
	faB(2, 23) = faJInv(2, 1) * faDS(8) + faJInv(2, 2) * faDS(16) + faJInv(2, 3) * faDS(24)
	faB(2, 24) = 0D0
	faB(3, 1) = 0D0
	faB(3, 2) = 0D0
	faB(3, 3) = faJInv(3, 1) * faDS(1) + faJInv(3, 2) * faDS(9) + faJInv(3, 3) * faDS(17)
	faB(3, 4) = 0D0
	faB(3, 5) = 0D0
	faB(3, 6) = faJInv(3, 1) * faDS(2) + faJInv(3, 2) * faDS(10) + faJInv(3, 3) * faDS(18)
	faB(3, 7) = 0D0
	faB(3, 8) = 0D0
	faB(3, 9) = faJInv(3, 1) * faDS(3) + faJInv(3, 2) * faDS(11) + faJInv(3, 3) * faDS(19)
	faB(3, 10) = 0D0
	faB(3, 11) = 0D0
	faB(3, 12) = faJInv(3, 1) * faDS(4) + faJInv(3, 2) * faDS(12) + faJInv(3, 3) * faDS(20)
	faB(3, 13) = 0D0
	faB(3, 14) = 0D0
	faB(3, 15) = faJInv(3, 1) * faDS(5) + faJInv(3, 2) * faDS(13) + faJInv(3, 3) * faDS(21)
	faB(3, 16) = 0D0
	faB(3, 17) = 0D0
	faB(3, 18) = faJInv(3, 1) * faDS(6) + faJInv(3, 2) * faDS(14) + faJInv(3, 3) * faDS(22)
	faB(3, 19) = 0D0
	faB(3, 20) = 0D0
	faB(3, 21) = faJInv(3, 1) * faDS(7) + faJInv(3, 2) * faDS(15) + faJInv(3, 3) * faDS(23)
	faB(3, 22) = 0D0
	faB(3, 23) = 0D0
	faB(3, 24) = faJInv(3, 1) * faDS(8) + faJInv(3, 2) * faDS(16) + faJInv(3, 3) * faDS(24)
	faB(4, 1) = faB(2, 2)
	faB(4, 2) = faB(1, 1)
	faB(4, 3) = 0D0
	faB(4, 4) = faB(2, 5)
	faB(4, 5) = faB(1, 4)
	faB(4, 6) = 0D0
	faB(4, 7) = faB(2, 8)
	faB(4, 8) = faB(1, 7)
	faB(4, 9) = 0D0
	faB(4, 10) = faB(2, 11)
	faB(4, 11) = faB(1, 10)
	faB(4, 12) = 0D0
	faB(4, 13) = faB(2, 14)
	faB(4, 14) = faB(1, 13)
	faB(4, 15) = 0D0
	faB(4, 16) = faB(2, 17)
	faB(4, 17) = faB(1, 16)
	faB(4, 18) = 0D0
	faB(4, 19) = faB(2, 20)
	faB(4, 20) = faB(1, 19)
	faB(4, 21) = 0D0
	faB(4, 22) = faB(2, 23)
	faB(4, 23) = faB(1, 22)
	faB(4, 24) = 0D0
	faB(5, 1) = 0D0
	faB(5, 2) = faB(3, 3)
	faB(5, 3) = faB(2, 2)
	faB(5, 4) = 0D0
	faB(5, 5) = faB(3, 6)
	faB(5, 6) = faB(2, 5)
	faB(5, 7) = 0D0
	faB(5, 8) = faB(3, 9)
	faB(5, 9) = faB(2, 8)
	faB(5, 10) = 0D0
	faB(5, 11) = faB(3, 12)
	faB(5, 12) = faB(2, 11)
	faB(5, 13) = 0D0
	faB(5, 14) = faB(3, 15)
	faB(5, 15) = faB(2, 14)
	faB(5, 16) = 0D0
	faB(5, 17) = faB(3, 18)
	faB(5, 18) = faB(2, 17)
	faB(5, 19) = 0D0
	faB(5, 20) = faB(3, 21)
	faB(5, 21) = faB(2, 20)
	faB(5, 22) = 0D0
	faB(5, 23) = faB(3, 24)
	faB(5, 24) = faB(2, 23)
	faB(6, 1) = faB(3, 3)
	faB(6, 2) = 0D0
	faB(6, 3) = faB(1, 1)
	faB(6, 4) = faB(3, 6)
	faB(6, 5) = 0D0
	faB(6, 6) = faB(1, 4)
	faB(6, 7) = faB(3, 9)
	faB(6, 8) = 0D0
	faB(6, 9) = faB(1, 7)
	faB(6, 10) = faB(3, 12)
	faB(6, 11) = 0D0
	faB(6, 12) = faB(1, 10)
	faB(6, 13) = faB(3, 15)
	faB(6, 14) = 0D0
	faB(6, 15) = faB(1, 13)
	faB(6, 16) = faB(3, 18)
	faB(6, 17) = 0D0
	faB(6, 18) = faB(1, 16)
	faB(6, 19) = faB(3, 21)
	faB(6, 20) = 0D0
	faB(6, 21) = faB(1, 19)
	faB(6, 22) = faB(3, 24)
	faB(6, 23) = 0D0
	faB(6, 24) = faB(1, 22)
End Subroutine

! ******************************************
! Integer function CalcOnlyKHexa8()
!
! IN:
! iElemNo(integer): Position in the elements matrix
!					of the element that the stiffness
!					matrix will be calculated.
!
! OUT:
! ---
!
! RETURNS:
! (integer): Number of nodes per element
!
! UPDATES:
! ---
!
! PURPOSE:
! Calculate the element stiffness matrix
!
! NOTES:
! ---
! ******************************************
Subroutine CalcH8GaussMatrices(iInt, faXYZ, faWeight, faS, faDS, faJ, faDetJ, faB)
  !DEC$ ATTRIBUTES DLLEXPORT::CalcH8GaussMatrices
	Implicit None

	Integer, Intent(IN) :: iInt
	Real, Intent(IN) :: faXYZ(3, 8)
	Real, Intent(OUT) :: faDS(24, iInt ** 3), faS(8, iInt ** 3), &
		faB(6, 24, iInt ** 3), faDetJ(iInt ** 3), faJ(3, 3, iInt ** 3), &
		faWeight(iInt ** 3)
	Real fXi, fEta, fZeta
	Integer M, iX, iY, iZ, iErr, CalcH8JDetJ
	Real GP(4, 4), GW(4, 4)
! GP Matrix stores Gauss - Legendre sampling points
    Data GP/ &
		0.D0,   0.D0,   0.D0,   0.D0,   -.5773502691896D0, &
		.5773502691896D0,   0.D0,   0.D0,   -.7745966692415D0,   0.D0, &
		.7745966692415D0,   0.D0,   -.8611363115941D0, &
		-.3399810435849D0,   .3399810435849D0,   .8611363115941D0 /
! GW Matrix stores Gauss - Legendre weighting factors
	Data GW/ &
		2.D0,   0.D0,   0.D0,   0.D0,   1.D0,   1.D0, &
		0.D0,  0.D0,    .5555555555556D0,   .8888888888889D0, &
		.5555555555556D0,   0.D0,   .3478548451375D0,   .6521451548625D0, &
		.6521451548625D0, 	 .3478548451375D0 /

! Main routine
	M = 0
	Do iX = 1, iInt
		fXi = GP(iX, iInt)
		Do iY = 1, iInt
			fEta = GP(iY, iInt)
			Do iZ = 1, iInt
				fZeta = GP(iZ, iInt)
				M = M + 1
				Call CalcH8NablaShape(fXi, fEta, fZeta, faDS(1, M))
				Call CalcH8Shape(fXi, fEta, fZeta, faS(1, M))
				iErr = CalcH8JDetJ(faXYZ, faDS(1, M), faJ(1, 1, M), faDetJ(M))
				Call CalcH8B(faDetJ(M), faJ(1, 1, M), faDS(1, M), faB(1, 1, M))
				faWeight(M) = GW(iX, iInt) * GW(iY, iInt) * GW(iZ, iInt) * faDetJ(M)
			EndDo
		EndDo
	EndDo
End Subroutine

! ******************************************
! Integer function CalcOnlyKHexa8()
!
! IN:
! iElemNo(integer): Position in the elements matrix
!					of the element that the stiffness
!					matrix will be calculated.
!
! OUT:
! ---
!
! RETURNS:
! (integer): Number of nodes per element
!
! UPDATES:
! ---
!
! PURPOSE:
! Calculate the element stiffness matrix
!
! NOTES:
! ---
! ******************************************
Subroutine CalcH8K(iInt, faE, faB, faWeight, faK)
  !DEC$ ATTRIBUTES DLLEXPORT::CalcH8K
	Implicit None

	Integer, Intent(IN) :: iInt
	Real, Intent(IN) :: faWeight(iInt ** 3), faB(6, 24, iInt ** 3), faE(6, 6, iInt ** 3)
	Real, Intent(OUT) :: faK(300)
	Real faEB(6)
	Real fStiff, fE1, fE2, fE3, fE4
	Integer I, J, K, M, KS, iX, iY, iZ

! Main routine
! Calculate stiffness matrix
	M = 0
	Do I = 1, 300
		faK(I) = 0D0
	EndDo
	Do iX = 1, iInt
		Do iY = 1, iInt
			Do iZ = 1, iInt
				M = M + 1
! Add contribution to element stiffness
				KS = 0
				Do I = 1, 24
					faEB(1) = faE(1, 1, M) * faB(1, I, M) + faE(1, 2, M) * faB(2, I, M) + &
						faE(1, 3, M) * faB(3, I, M) + faE(1, 4, M) * faB(4, I, M) + &
						faE(1, 5, M) * faB(5, I, M) + faE(1, 6, M) * faB(6, I, M)
					faEB(2) = faE(2, 1, M) * faB(1, I, M) + faE(2, 2, M) * faB(2, I, M) + &
						faE(2, 3, M) * faB(3, I, M) + faE(2, 4, M) * faB(4, I, M) + &
						faE(2, 5, M) * faB(5, I, M) + faE(2, 6, M) * faB(6, I, M)
					faEB(3) = faE(3, 1, M) * faB(1, I, M) + faE(3, 2, M) * faB(2, I, M) + &
						faE(3, 3, M) * faB(3, I, M) + faE(3, 4, M) * faB(4, I, M) + &
						faE(3, 5, M) * faB(5, I, M) + faE(3, 6, M) * faB(6, I, M)
					faEB(4) = faE(4, 1, M) * faB(1, I, M) + faE(4, 2, M) * faB(2, I, M) + &
						faE(4, 3, M) * faB(3, I, M) + faE(4, 4, M) * faB(4, I, M) + &
						faE(4, 5, M) * faB(5, I, M) + faE(4, 6, M) * faB(6, I, M)
					faEB(5) = faE(5, 1, M) * faB(1, I, M) + faE(5, 2, M) * faB(2, I, M) + &
						faE(5, 3, M) * faB(3, I, M) + faE(5, 4, M) * faB(4, I, M) + &
						faE(5, 5, M) * faB(5, I, M) + faE(5, 6, M) * faB(6, I, M)
					faEB(6) = faE(6, 1, M) * faB(1, I, M) + faE(6, 2, M) * faB(2, I, M) + &
						faE(6, 3, M) * faB(3, I, M) + faE(6, 4, M) * faB(4, I, M) + &
						faE(6, 5, M) * faB(5, I, M) + faE(6, 6, M) * faB(6, I, M)

					Do J = I, 24
						KS = KS + 1
						fStiff = faB(1, J, M) * faEB(1) + faB(2, J, M) * faEB(2) + &
							faB(3, J, M) * faEB(3) + faB(4, J, M) * faEB(4) + &
							faB(5, J, M) * faEB(5) + faB(6, J, M) * faEB(6)
						faK(KS) = faK(KS) + fStiff * faWeight(M)
					EndDo
				EndDo
			EndDo
		EndDo
	EndDo
End Subroutine

! ******************************************
! Integer function CalcOnlyMHexa8(iElemNo)
!
! IN:
! iElemNo(integer): Position in the elements matrix
!					of the element that the stiffness
!					matrix will be calculated.
!
! OUT:
! ---
!
! RETURNS:
! (integer): Number of nodes per element
!
! UPDATES:
! ---
!
! PURPOSE:
! Calculate the element stiffness matrix
!
! NOTES:
! ---
! ******************************************
Integer Function CalcH8MConsistent(iInt, fDensity, faS, faWeight, faM)
	Implicit None

	Integer, Intent(IN) :: iInt
	Real, Intent(IN) :: fDensity, faWeight(iInt ** 3), faS(8, iInt ** 3)
	Real, Intent(OUT) :: faM(300)
	Integer I, J, K, M, KS, iX, iY, iZ, iWidth, iS2, iS1
	Real fWeight

! Main routine
	M = 0
	Do I = 1, 300
		faM(I) = 0D0
	EndDo
	Do iX = 1, iInt
		Do iY = 1, iInt
			Do iZ = 1, iInt
				M = M + 1
				KS = -2
				fWeight = faWeight(M) * fDensity
				Do I = 1, 8
					Do J = I, 8
						KS = KS + 3
						faM(KS) = faM(KS) + faS(I, M) * faS(J, M) * fWeight
					EndDo

					iWidth = 27 - 3 * I
					Do J = I, 8
						KS = KS + 3
						faM(KS) = faM(KS - iWidth)
					EndDo
					KS = KS - 1
					iWidth = 26 - 3 * I
					Do J = I, 8
						KS = KS + 3
						faM(KS) = faM(KS - iWidth)
					EndDo
					KS = KS - 2
				EndDo
			EndDo
		EndDo
	EndDo
End Function

! ******************************************
! Integer function CalcOnlyMHexa8(iElemNo)
!
! IN:
! iElemNo(integer): Position in the elements matrix
!					of the element that the stiffness
!					matrix will be calculated.
!
! OUT:
! ---
!
! RETURNS:
! (integer): Number of nodes per element
!
! UPDATES:
! ---
!
! PURPOSE:
! Calculate the element stiffness matrix
!
! NOTES:
! ---
! ******************************************
Subroutine CalcH8Strains(iInt, faB, fau, faStrains)
  !DEC$ ATTRIBUTES DLLEXPORT::CalcH8Strains
	Implicit None

	Integer, Intent(IN) :: iInt
	Real, Intent(IN) :: faB(6, 24, iInt ** 3), fau(24)
	Real, Intent(OUT) :: faStrains(6, iInt ** 3)
	Integer :: M

! Main routine
	Do M = 1, iInt ** 3
		faStrains(:, M) = MatMul(faB(:, :, M), fau)
	EndDo
End Subroutine

! ******************************************
! Integer function CalcOnlyMHexa8(iElemNo)
!
! IN:
! iElemNo(integer): Position in the elements matrix
!					of the element that the stiffness
!					matrix will be calculated.
!
! OUT:
! ---
!
! RETURNS:
! (integer): Number of nodes per element
!
! UPDATES:
! ---
!
! PURPOSE:
! Calculate the element stiffness matrix
!
! NOTES:
! ---
! ******************************************
Integer Function CalcH8MLumped(iInt, fDensity, faWeight, faM)
  !DEC$ ATTRIBUTES DLLEXPORT::CalcH8MLumped
	Implicit None

	Integer, Intent(IN) :: iInt
	Real, Intent(IN) :: fDensity, faWeight(iInt ** 3)
	Real, Intent(OUT) :: faM(300)
	Integer M, iS2, iS1
	Real fMassTerm

! Main routine
	Do M = 1, 300
		faM(M) = 0D0
	EndDo

	fMassTerm = 0D0
	Do M = 1, iInt ** 3
		fMassTerm = fMassTerm + faWeight(M)
	EndDo
	fMassTerm = fMassTerm * fDensity * 0.125D0

	iS2 = 1
	Do iS1 = 24, 1, -1
		faM(iS2) = fMassTerm
		iS2 = iS2 + iS1
	EndDo
End Function

! ******************************************
! Integer function CalcOnlyKHexa8()
!
! IN:
! iElemNo(integer): Position in the elements matrix
!					of the element that the stiffness
!					matrix will be calculated.
!
! OUT:
! ---
!
! RETURNS:
! (integer): Number of nodes per element
!
! UPDATES:
! ---
!
! PURPOSE:
! Calculate the element stiffness matrix
!
! NOTES:
! ---
! ******************************************
Subroutine CalcH8Forces(iInt, faB, faWeight, faStresses, faForces)
  !DEC$ ATTRIBUTES DLLEXPORT::CalcH8Forces
	Implicit None

	Integer, Intent(IN) :: iInt
	Real, Intent(IN) :: faWeight(iInt ** 3), faB(6, 24, iInt ** 3), faStresses(6, iInt ** 3)
	Real, Intent(OUT) :: faForces(24)
	Integer :: M, iX, iY, iZ

! Main routine
! Calculate stiffness matrix
	M = 0
	Do iX = 1, 24
		faForces(iX) = 0D0
	EndDo
	Do iX = 1, iInt
		Do iY = 1, iInt
			Do iZ = 1, iInt
				M = M + 1
				faForces = faForces + faWeight(M) * MatMul(Transpose(faB(:, :, M)), faStresses(:, M))
			EndDo
		EndDo
	EndDo
End Subroutine

Subroutine CalcH8ForcesFromDisp(piEqLM, pfElementK, pfU, pfGlobalForces)
	Implicit None

	Integer, Intent(IN) :: piEqLM(1)
	Real, Intent(IN) :: pfElementK(1), pfU(24)
	Real, Intent(OUT) :: pfGlobalForces(1)

	Integer :: I, J, iRow, iAccR, iTemp, iDataPos
	Real :: fLocalForces(24)

! Main function
! Initialize local forces vector
	fLocalForces(1) = 0D0
	fLocalForces(2) = 0D0
	fLocalForces(3) = 0D0
	fLocalForces(4) = 0D0
	fLocalForces(5) = 0D0
	fLocalForces(6) = 0D0
	fLocalForces(7) = 0D0
	fLocalForces(8) = 0D0
	fLocalForces(9) = 0D0
	fLocalForces(10) = 0D0
	fLocalForces(11) = 0D0
	fLocalForces(12) = 0D0
	fLocalForces(13) = 0D0
	fLocalForces(14) = 0D0
	fLocalForces(15) = 0D0
	fLocalForces(16) = 0D0
	fLocalForces(17) = 0D0
	fLocalForces(18) = 0D0
	fLocalForces(19) = 0D0
	fLocalForces(20) = 0D0
	fLocalForces(21) = 0D0
	fLocalForces(22) = 0D0
	fLocalForces(23) = 0D0
	fLocalForces(24) = 0D0

! Multiply SKYLINE Element K with vector pfU and store to fLocalForces
	iDataPos = 1
	Do I = 1, 24
		fLocalForces(I) = fLocalForces(I) + pfElementK(iDataPos) * pfU(I)
		iDataPos = iDataPos + 1
		Do J = I + 1, 24
			fLocalForces(I) = fLocalForces(I) + pfElementK(iDataPos) * pfU(J)
			fLocalForces(J) = fLocalForces(J) + pfElementK(iDataPos) * pfU(I)
			iDataPos = iDataPos + 1
		End Do
	End Do

! Update the global loads vector (pfGlobalForces)
	iTemp = piEqLM(1)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(1)
	iTemp = piEqLM(2)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(2)
	iTemp = piEqLM(3)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(3)
	iTemp = piEqLM(4)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(4)
	iTemp = piEqLM(5)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(5)
	iTemp = piEqLM(6)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(6)
	iTemp = piEqLM(7)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(7)
	iTemp = piEqLM(8)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(8)
	iTemp = piEqLM(9)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(9)
	iTemp = piEqLM(10)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(10)
	iTemp = piEqLM(11)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(11)
	iTemp = piEqLM(12)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(12)
	iTemp = piEqLM(13)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(13)
	iTemp = piEqLM(14)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(14)
	iTemp = piEqLM(15)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(15)
	iTemp = piEqLM(16)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(16)
	iTemp = piEqLM(17)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(17)
	iTemp = piEqLM(18)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(18)
	iTemp = piEqLM(19)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(19)
	iTemp = piEqLM(20)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(20)
	iTemp = piEqLM(21)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(21)
	iTemp = piEqLM(22)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(22)
	iTemp = piEqLM(23)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(23)
	iTemp = piEqLM(24)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(24)
End Subroutine

Subroutine CalcH8ForcesAcc(iInt, bIsLumped, fDensity, afAcc, afS, afWeights, afLocalForces)
	Implicit None
	Integer, Intent(IN) :: iInt
	Logical, Intent(IN) :: bIsLumped
	Real, Intent(IN) :: fDensity, afS(8, iInt ** 3), afAcc(3), afWeights(*)
	Real, Intent(OUT) :: afLocalForces(24)
	Integer :: I, J, iAccR, iDataPos, CalcH8MLumped, CalcH8MConsistent
	Real :: afM(300)

! Main function
! Initialize local forces vector
	afLocalForces(1) = 0D0
	afLocalForces(2) = 0D0
	afLocalForces(3) = 0D0
	afLocalForces(4) = 0D0
	afLocalForces(5) = 0D0
	afLocalForces(6) = 0D0
	afLocalForces(7) = 0D0
	afLocalForces(8) = 0D0
	afLocalForces(9) = 0D0
	afLocalForces(10) = 0D0
	afLocalForces(11) = 0D0
	afLocalForces(12) = 0D0
	afLocalForces(13) = 0D0
	afLocalForces(14) = 0D0
	afLocalForces(15) = 0D0
	afLocalForces(16) = 0D0
	afLocalForces(17) = 0D0
	afLocalForces(18) = 0D0
	afLocalForces(19) = 0D0
	afLocalForces(20) = 0D0
	afLocalForces(21) = 0D0
	afLocalForces(22) = 0D0
	afLocalForces(23) = 0D0
	afLocalForces(24) = 0D0
	If (bIsLumped) Then
		I = CalcH8MLumped(iInt, fDensity, afWeights, afM)
	Else
		I = CalcH8MConsistent(iInt, fDensity, afS, afWeights, afM)
	End If

! Multiply SKYLINE Element M with vector pfAcc and store to fLocalForces
	iDataPos = 1
	Do I = 1, 24
		iAccR = mod(I - 1, 3) + 1
		afLocalForces(I) = afLocalForces(I) + afM(iDataPos) * afAcc(iAccR)
		iDataPos = iDataPos + 1
		Do J = I + 1, 24
			afLocalForces(I) = afLocalForces(I) + afM(iDataPos) * afAcc(mod(J - 1, 3) + 1)
			afLocalForces(J) = afLocalForces(J) + afM(iDataPos) * afAcc(iAccR)
			iDataPos = iDataPos + 1
		End Do
	End Do
End Subroutine

Subroutine CalcH8ForcesFromAcc(piEqLM, pfElementM, pfAcc, pfGlobalForces)
	Implicit None

	Integer, Intent(IN) :: piEqLM(1)
	Real, Intent(IN) :: pfElementM(1), pfAcc(3)
	Real, Intent(OUT) :: pfGlobalForces(1)

	Integer :: I, J, iRow, iAccR, iTemp, iDataPos
	Real :: fLocalForces(24)

! Main function
! Initialize local forces vector
	fLocalForces(1) = 0D0
	fLocalForces(2) = 0D0
	fLocalForces(3) = 0D0
	fLocalForces(4) = 0D0
	fLocalForces(5) = 0D0
	fLocalForces(6) = 0D0
	fLocalForces(7) = 0D0
	fLocalForces(8) = 0D0
	fLocalForces(9) = 0D0
	fLocalForces(10) = 0D0
	fLocalForces(11) = 0D0
	fLocalForces(12) = 0D0
	fLocalForces(13) = 0D0
	fLocalForces(14) = 0D0
	fLocalForces(15) = 0D0
	fLocalForces(16) = 0D0
	fLocalForces(17) = 0D0
	fLocalForces(18) = 0D0
	fLocalForces(19) = 0D0
	fLocalForces(20) = 0D0
	fLocalForces(21) = 0D0
	fLocalForces(22) = 0D0
	fLocalForces(23) = 0D0
	fLocalForces(24) = 0D0

! Multiply SKYLINE Element M with vector pfAcc and store to fLocalForces
	iDataPos = 1
	Do I = 1, 24
		iAccR = mod(I - 1, 3) + 1
		fLocalForces(I) = fLocalForces(I) + pfElementM(iDataPos) * pfAcc(iAccR)
		iDataPos = iDataPos + 1
		Do J = I + 1, 24
			fLocalForces(I) = fLocalForces(I) + pfElementM(iDataPos) * pfAcc(mod(J - 1, 3) + 1)
			fLocalForces(J) = fLocalForces(J) + pfElementM(iDataPos) * pfAcc(iAccR)
			iDataPos = iDataPos + 1
		End Do
	End Do

! Update the global loads vector (pfGlobalForces)
	iTemp = piEqLM(1)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(1)
	iTemp = piEqLM(2)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(2)
	iTemp = piEqLM(3)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(3)
	iTemp = piEqLM(4)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(4)
	iTemp = piEqLM(5)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(5)
	iTemp = piEqLM(6)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(6)
	iTemp = piEqLM(7)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(7)
	iTemp = piEqLM(8)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(8)
	iTemp = piEqLM(9)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(9)
	iTemp = piEqLM(10)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(10)
	iTemp = piEqLM(11)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(11)
	iTemp = piEqLM(12)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(12)
	iTemp = piEqLM(13)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(13)
	iTemp = piEqLM(14)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(14)
	iTemp = piEqLM(15)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(15)
	iTemp = piEqLM(16)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(16)
	iTemp = piEqLM(17)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(17)
	iTemp = piEqLM(18)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(18)
	iTemp = piEqLM(19)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(19)
	iTemp = piEqLM(20)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(20)
	iTemp = piEqLM(21)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(21)
	iTemp = piEqLM(22)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(22)
	iTemp = piEqLM(23)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(23)
	iTemp = piEqLM(24)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(24)
End Subroutine


program Combinations
  use iso_fortran_env
  implicit none

  type comb_result
     integer, dimension(:), allocatable :: combs
  end type comb_result

  type(comb_result), dimension(:), pointer :: r
  integer :: i, j

  call comb(5, 3, r)
  do i = 0, choose(5, 3) - 1
     do j = 2, 0, -1
        write(*, "(I4, ' ')", advance="no") r(i)%combs(j)
     end do
     deallocate(r(i)%combs)
     write(*,*) ""
  end do
  deallocate(r)

contains

  function choose(n, k, err)
    integer :: choose
    integer, intent(in) :: n, k
    integer, optional, intent(out) :: err

    integer :: imax, i, imin, ie

    ie = 0
    if ( (n < 0 ) .or. (k < 0 ) ) then
       write(ERROR_UNIT, *) "negative in choose"
       choose = 0
       ie = 1
    else
       if ( n < k ) then
          choose = 0
       else if ( n == k ) then
          choose = 1
       else
          imax = max(k, n-k)
          imin = min(k, n-k)
          choose = 1
          do i = imax+1, n
             choose = choose * i
          end do
          do i = 2, imin
             choose = choose / i
          end do
       end if
    end if
    if ( present(err) ) err = ie
  end function choose

  subroutine comb(n, k, co)
    integer, intent(in) :: n, k
    type(comb_result), dimension(:), pointer, intent(out) :: co

    integer :: i, j, s, ix, kx, hm, t
    integer :: err

    hm = choose(n, k, err)
    if ( err /= 0 ) then
       nullify(co)
       return
    end if

    allocate(co(0:hm-1))
    do i = 0, hm-1
       allocate(co(i)%combs(0:k-1))
    end do
    do i = 0, hm-1
       ix = i; kx = k
       do s = 0, n-1
          if ( kx == 0 ) exit
          t = choose(n-(s+1), kx-1)
          if ( ix < t ) then
             co(i)%combs(kx-1) = s
             kx = kx - 1
          else
             ix = ix - t
          end if
       end do
    end do

  end subroutine comb

end program Combinations


! NOTE: We use atomic units throughout the program
program simple_md
   implicit none

   integer, parameter :: N_PARTICLES = 2
   integer, parameter :: N_STEP = 100
   ! TODO: Implement printing every 2nd step
   integer, parameter :: N_PRINT = 2
   ! TODO: Determine suitable timestep
   real(8), parameter :: DT = ??
   real(8), parameter :: AMU = 1823.0D0
   real(8), dimension(N_PARTICLES) :: mass
   real(8), dimension(N_PARTICLES) :: x, y
   real(8), dimension(N_PARTICLES) :: vx, vy
   real(8), dimension(N_PARTICLES) :: fx, fy

   character(len=20) :: potential = 'harmonic'
   ! Bond legth of N2 molecule
   ! https://cccbdb.nist.gov/exp2x.asp?casno=7727379
   real(8) :: r_eq = 1.098D0
   ! harmonic force constant in a.u. equivalent to 2359 cm^-1 vibration
   real(8) :: force_constant = 1.47497D0

   real(8) :: potential_energy
   real(8) :: calculate_kinetic_energy
   integer :: istep
   ! File units for output
   integer :: ucoords

   ! Defining inital conditions
   ! ================================
   ! Let's start with two particles bound by harmonic potential
   ! Specifically, let's simulate N2 molecule.
   x = 0.0D0
   y = (/ 0.0D0, 1.1D0 /)
   mass(1) = 14.0067 * AMU
   mass(2) = 14.0067 * AMU

   fx = 0.0D0
   fy = 0.0D0
   vx = 0.0D0
   vy = 0.0D0

   potential_energy = 0.0D0

   ! ================================
   open (newunit=ucoords, file='coords.xyz', action='write')

   ! MD LOOP, using Velocity Verlet integrator
   do istep = 1, N_STEP

      ! Implicit iteration here
      ! We can do simple matrix math with arrays as long as they have the same size
      vx = vx + fx / mass * DT * 0.5D0
      vy = vy + fy / mass * DT * 0.5D0

      x = x + vx * DT
      y = y + vy * DT

      if (potential == 'harmonic') then
         call harmonic_forces(force_constant, r_eq, x, y, fx, fy, potential_energy)
      else if (potential == 'morse') then
         ! TODO:
         print *, 'Morse potential not yet implemented'
      else
         print *, 'Invalid potential'
         stop 1
      end if

      vx = vx + fx / mass * DT * 0.5D0
      vy = vy + fy / mass * DT * 0.5D0

      call write_coords(N_PARTICLES, x, y, ucoords)

   end do

   close(ucoords)
end program

real(8) function calculate_kinetic_energy(n_particles, vx, vy, mass) result(e_k)
   implicit none
   integer, intent(in) :: n_particles
   real(8), dimension(n_particles), intent(in) :: vx, vy, mass
   integer :: i
   e_k = 0
   do i = 1, N_PARTICLES
      e_k = e_k + 0.5D0 * mass(i) * (vx(i)**2 + vy(i)**2)
   end do
end function

subroutine write_coords(natoms, x, y, channel)
   implicit none
   integer, intent(in) :: natoms
   real(8), dimension(natoms), intent(in) :: x, y
   integer, intent(in) :: channel
   integer :: i

   write (channel, *) natoms
   write (channel, *) 'comment line'
   do i = 1, natoms
      write (channel, '(A,3F10.5)') "N", x(i), y(i), 0.0D0
   end do
end subroutine write_coords

subroutine harmonic_forces(k, r_eq, x, y, fx, fy, potential_energy)
   implicit none
   real(8), intent(in) :: k, r_eq
   real(8), dimension(2), intent(in) :: x, y
   real(8), dimension(2), intent(out) :: fx, fy
   real(8), intent(out) :: potential_energy
   real(8) :: r, delta_x, delta_y

   delta_x = x(1) - x(2)
   delta_y = y(1) - y(2)
   r = delta_x**2 + delta_y**2
   r = dsqrt(r)

   fx(1) = - k * delta_x * (r - r_eq) / r
   fx(2) = - fx(1)
   fy(1) = - k * delta_y * (r - r_eq) / r
   fy(2) = - fy(1)

   potential_energy = 0.5D0 * k * (r - r_eq)**2
end subroutine harmonic_forces


C--------------------------------------------------------------
C THIS IS A TEST OF MODULE RFT2CH
C
C PORTED TO UNIX 6/25/93
C--------------------------------------------------------------
	INCLUDE 'VICMAIN_FOR'
	SUBROUTINE MAIN44
	REAL*4 BUF(20),BUF2(20,22)
C---------------------------------
C FORTRAN - CALLABLE
C---------------------------------

        CALL XVMESSAGE('*******FORTRAN-CALLABLE RFT2CH******',' ')
	CALL QPRINT('01-D CASE',9)
C
C-----CONSTRUCT INPUT VECTOR
	N=20
	DO 10 I=1,N
10	BUF(I) = I
	CALL PRNT(7,N,BUF,' INPUT R*4.')
C
C-----DO TRANSFORM
	CALL RFT2CH(BUF,1,N,1)
C
	CALL PRNT(7,N+2,BUF,' CMPLX XFORM.')
C-----INVERT TRANSFORM
	CALL RFT2CH(BUF,1,N,-1)
C
C-----RESCALE
	A=2*N
	CALL DIVV(7,N,A,BUF,0,1)
	CALL PRNT(7,N,BUF,' INVRS XFORM.')
C
C
C---------------------------------------------------------
	CALL QPRINT('02-D CASE',9)
	N=20
	M=20
C-----CONSTRUCT INPUT ARRAY
	DO 20 J=1,M
	DO 150 I=1,N
150	BUF2(I,J) = I + J
20	CALL PRNT(7,N,BUF2(1,J),' INPUT R*4.')
C
C-----DO TRANSFORM
	CALL RFT2CH(BUF2,M,N,1)
	DO 30 J=1,M+2
30	CALL PRNT(7,N,BUF2(1,J),' CMPLX XFORM.')
C
C-----DO INVERSE
	CALL RFT2CH(BUF2,M,N,-1)
C
	A=2*M*N
	DO 40 J=1,M
	CALL DIVV(7,N,A,BUF2(1,J),0,1)
40	CALL  PRNT(7,N,BUF2(1,J),' INVRS XFORM.')
C
C--------------------------------------------------------------
C ----C-CALLABLE
C--------------------------------------------------------------
        CALL XVMESSAGE('**********C-CALLABLE RFT2CH*******',' ')
	CALL QPRINT('01-D CASE',9)
C
C-----CONSTRUCT INPUT VECTOR
	N=20
	DO 210 I=1,N
210	BUF(I) = I
	CALL PRNT(7,N,BUF,' INPUT R*4.')
C
C-----DO TRANSFORM
	CALL TZRFT2CH(BUF,1,N,1)
C
	CALL PRNT(7,N+2,BUF,' CMPLX XFORM.')
C-----INVERT TRANSFORM
	CALL TZRFT2CH(BUF,1,N,-1)
C
C-----RESCALE
	A=2*N
	CALL DIVV(7,N,A,BUF,0,1)
	CALL PRNT(7,N,BUF,' INVRS XFORM.')
C
C
C---------------------------------------------------------
	CALL QPRINT('02-D CASE',9)
	N=20
	M=20
C-----CONSTRUCT INPUT ARRAY
	DO 220 J=1,M
	DO 350 I=1,N
350	BUF2(I,J) = I + J
220	CALL PRNT(7,N,BUF2(1,J),' INPUT R*4.')
C
C-----DO TRANSFORM
	CALL TZRFT2CH(BUF2,M,N,1)
	DO 230 J=1,M+2
230	CALL PRNT(7,N,BUF2(1,J),' CMPLX XFORM.')
C
C-----DO INVERSE
	CALL TZRFT2CH(BUF2,M,N,-1)
C
	A=2*M*N
	DO 240 J=1,M
	CALL DIVV(7,N,A,BUF2(1,J),0,1)
240	CALL  PRNT(7,N,BUF2(1,J),' INVRS XFORM.')
C
	RETURN
	END


! Integro diff eq. 13 oct 2014 (Reformatted)
! http://www.uprh.edu/rbaretti/IntegroDE13oct2014.htm

! declarations: types, data, and print format
      implicit real*8 (a-h, o-z)
      data nstep, L /2000, 4.d0/
  100 format('x, phi, phiex, ratio = ' 4(3x, e10.3))

! initial values:
      phiex(x) = (1.d0 / 2.d0)    &
                 * dexp(-x)       &
                 * dsin(2.d0 * x)
      dx       = L / dfloat(nstep)
      kp       = int(dfloat(nstep) / 40.d0)
      kount    = kp
      phi0     = 0.d0
      uprime0  = 1.d0
      phi1     = phi0 + dx * uprime0

! print initial values
      print 100,               &
            0.d0,              &
            phi0,              &
            phiex(0.d0),       &
            phi0 / phiex(0.d0)

! for loop
      do i = 2, nstep
          x      = dx * dfloat(i)
          dphidx = (phi1 - phi0) / dx

! because i >= 2, this block is never entered,
! making the if statement is unnecessary
          if (i .eq. 1) then
              phi2 = 2.d0 * phi1         &
                     - phi0              &
                     + dx ** 2           &
                     * (- 2.d0 * dphidx  &
                        - 5.d0 * phi1    &
                        + 1.d0 / dx)
          else
              phi2 = 2.d0 * phi1         &
                     - phi0              &
                     + dx ** 2           &
                     * (- 2.d0 * dphidx  &
                        - 5.d0 * phi1)
          end if
! every kp number of iterations, print
          if (i .eq. kount) then
              print 100,            &
                    x,              &
                    phi2,           &
                    phiex(x),       &
                    phi2 / phiex(x)
              kount = kount + kp
          end if

          phi0 = phi1
          phi1 = phi2
      end do
      stop
      end

! approximation for dirac delta function
! 1/dx near zero, 0 elsewhere
      function delta(x, dx)
          implicit real*8 (a-h, o-z)
          if (x .le. dx) then
              delta = 1.d0 / dx
          else
              delta = 0.d0
          end if
          return
      end


Program final
	Implicit none
	real*8 :: infty, x, dx, e, de, tol
	real*8, dimension(2) :: y
	real*8, external :: f_x, g_x
	character (len=10) :: filename
	integer :: n=1

! parameters
	tol = epsilon(0.0d0) ! tolerance of 0
	infty = 4.d0 ! where psi(infty) is considered to be tol

	dx = 0.1d-3

	open(10, file="psi.dat")

	e = -6.d0
	do while (e.lt.0)
		x = -infty
		y(1) = 0.02 ! initial psi at x=infty
		y(2) = tol ! initial psi' at x=infty

		do while( x.le.infty )
			call rk4(x, dx, f_x, g_x, y, e)
			x = x + dx
		enddo
		de = 4.9d0**( log10(abs(y(1))) - 26 )
		write(10,*) e, y(1), de
		e = e + de
		print *, e, de, y(1)
	enddo
	close(10)

end program final

! 4th-order Runge-Kutta subroutine
subroutine rk4(x, dx, df, dg, y, e)
	implicit none
	real*8, external :: df, dg
	real*8, intent(in) :: x, dx, e
	real*8, intent(inout), dimension(2) :: y
	real*8 :: h, k0, k1, k2, k3, l0, l1, l2, l3

	h=dx/2.0D0

	k0 = dx * df(y(1),y(2))
	l0 = dx * dg(y(1),y(2),x,e)
	k1 = dx * df(y(1)+h, y(2)+0.5d0*l0)
	l1 = dx * dg(y(1)+0.5d0*k0,y(2)+0.5d0*l0,x,e)
	k2 = dx * df(y(1)+0.5d0*k1,y(2)+0.5d0*l1)
	l2 = dx * dg(y(1)+0.5d0*k1,y(2)+0.5d0*l1,x,e)
	k3 = dx * df(y(1)+k2,y(2)+l2)
	l3 = dx * dg(y(1)+k2,y(2)+l2,x,e)
	y(1) = y(1) + (k0+2*k1+2*k2+k3)/6.0d0
	y(2) = y(2) + (l0+2*l1+2*l2+l3)/6.0d0
	Return
End subroutine rk4

! function which returns the derivatives (RHS)
real*8 function f_x(y, yp)
! dpsi/dx = psi'
	Implicit none
	real*8 ,intent(in) :: y, yp
	f_x = yp
	Return
End function f_x

real*8 function g_x(y, yp, x, e)
! d^2y/dx^2 = 2(V(x)-e)*y = (4x^4-16x^2-2e)y
	implicit none
	real*8, intent(in) :: y, yp, x, e
!	g_x = ( -4.0d0 - e) * y
	g_x = ( 4.0d0 * x**4.0d0 - 16.0d0 * x**2.0d0 - 2.0d0*e) * y
!	g_x = 2.d0 * ( (x+sqrt(2.d0))**2.d0-8 - e) * y
	Return
End function g_x


*DECK HSTCRT
      SUBROUTINE HSTCRT (A, B, M, MBDCND, BDA, BDB, C, D, N, NBDCND,
     +   BDC, BDD, ELMBDA, F, IDIMF, PERTRB, IERROR, W)
C***BEGIN PROLOGUE  HSTCRT
C***PURPOSE  Solve the standard five-point finite difference
C            approximation on a staggered grid to the Helmholtz equation
C            in Cartesian coordinates.
C***LIBRARY   SLATEC (FISHPACK)
C***CATEGORY  I2B1A1A
C***TYPE      SINGLE PRECISION (HSTCRT-S)
C***KEYWORDS  ELLIPTIC, FISHPACK, HELMHOLTZ, PDE
C***AUTHOR  Adams, J., (NCAR)
C           Swarztrauber, P. N., (NCAR)
C           Sweet, R., (NCAR)
C***DESCRIPTION
C
C      HSTCRT solves the standard five-point finite difference
C      approximation on a staggered grid to the Helmholtz equation in
C      Cartesian coordinates
C
C      (d/dX)(dU/dX) + (d/dY)(dU/dY) + LAMBDA*U = F(X,Y)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     * * * * * * * *    Parameter Description     * * * * * * * * * *
C
C             * * * * * *   On Input    * * * * * *
C
C    A,B
C      The range of X, i.e. A .LE. X .LE. B.  A must be less than B.
C
C    M
C      The number of grid points in the interval (A,B).  The grid points
C      in the X-direction are given by X(I) = A + (I-0.5)dX for
C      I=1,2,...,M where dX =(B-A)/M.  M must be greater than 2.
C
C    MBDCND
C      Indicates the type of boundary conditions at X = A and X = B.
C
C      = 0  If the solution is periodic in X,
C           U(M+I,J) = U(I,J).
C
C      = 1  If the solution is specified at X = A and X = B.
C
C      = 2  If the solution is specified at X = A and the derivative
C           of the solution with respect to X is specified at X = B.
C
C      = 3  If the derivative of the solution with respect to X is
C           specified at X = A  and X = B.
C
C      = 4  If the derivative of the solution with respect to X is
C           specified at X = A  and the solution is specified at X = B.
C
C    BDA
C      A one-dimensional array of length N that specifies the boundary
C      values (if any) of the solution at X = A.  When MBDCND = 1 or 2,
C
C               BDA(J) = U(A,Y(J)) ,          J=1,2,...,N.
C
C      When MBDCND = 3 or 4,
C
C               BDA(J) = (d/dX)U(A,Y(J)) ,    J=1,2,...,N.
C
C    BDB
C      A one-dimensional array of length N that specifies the boundary
C      values of the solution at X = B.  When MBDCND = 1 or 4
C
C               BDB(J) = U(B,Y(J)) ,          J=1,2,...,N.
C
C      When MBDCND = 2 or 3
C
C               BDB(J) = (d/dX)U(B,Y(J)) ,    J=1,2,...,N.
C
C    C,D
C      The range of Y, i.e. C .LE. Y .LE. D.  C must be less
C      than D.
C
C    N
C      The number of unknowns in the interval (C,D).  The unknowns in
C      the Y-direction are given by Y(J) = C + (J-0.5)DY,
C      J=1,2,...,N, where DY = (D-C)/N.  N must be greater than 2.
C
C    NBDCND
C      Indicates the type of boundary conditions at Y = C
C      and Y = D.
C
C      = 0  If the solution is periodic in Y, i.e.
C           U(I,J) = U(I,N+J).
C
C      = 1  If the solution is specified at Y = C and Y = D.
C
C      = 2  If the solution is specified at Y = C and the derivative
C           of the solution with respect to Y is specified at Y = D.
C
C      = 3  If the derivative of the solution with respect to Y is
C           specified at Y = C and Y = D.
C
C      = 4  If the derivative of the solution with respect to Y is
C           specified at Y = C and the solution is specified at Y = D.
C
C    BDC
C      A one dimensional array of length M that specifies the boundary
C      values of the solution at Y = C.   When NBDCND = 1 or 2,
C
C               BDC(I) = U(X(I),C) ,              I=1,2,...,M.
C
C      When NBDCND = 3 or 4,
C
C               BDC(I) = (d/dY)U(X(I),C),     I=1,2,...,M.
C
C      When NBDCND = 0, BDC is a dummy variable.
C
C    BDD
C      A one-dimensional array of length M that specifies the boundary
C      values of the solution at Y = D.  When NBDCND = 1 or 4,
C
C               BDD(I) = U(X(I),D) ,              I=1,2,...,M.
C
C      When NBDCND = 2 or 3,
C
C               BDD(I) = (d/dY)U(X(I),D) ,    I=1,2,...,M.
C
C      When NBDCND = 0, BDD is a dummy variable.
C
C    ELMBDA
C      The constant LAMBDA in the Helmholtz equation.  If LAMBDA is
C      greater than 0, a solution may not exist.  However, HSTCRT will
C      attempt to find a solution.
C
C    F
C      A two-dimensional array that specifies the values of the right
C      side of the Helmholtz equation.  For I=1,2,...,M and J=1,2,...,N
C
C               F(I,J) = F(X(I),Y(J)) .
C
C      F must be dimensioned at least M X N.
C
C    IDIMF
C      The row (or first) dimension of the array F as it appears in the
C      program calling HSTCRT.  This parameter is used to specify the
C      variable dimension of F.  IDIMF must be at least M.
C
C    W
C      A one-dimensional array that must be provided by the user for
C      work space.  W may require up to 13M + 4N + M*INT(log2(N))
C      locations.  The actual number of locations used is computed by
C      HSTCRT and is returned in the location W(1).
C
C
C             * * * * * *   On Output   * * * * * *
C
C    F
C      Contains the solution U(I,J) of the finite difference
C      approximation for the grid point (X(I),Y(J)) for
C      I=1,2,...,M, J=1,2,...,N.
C
C    PERTRB
C      If a combination of periodic or derivative boundary conditions is
C      specified for a Poisson equation (LAMBDA = 0), a solution may not
C      exist.  PERTRB is a constant, calculated and subtracted from F,
C      which ensures that a solution exists.  HSTCRT then computes this
C      solution, which is a least squares solution to the original
C      approximation.  This solution plus any constant is also a
C      solution; hence, the solution is not unique.  The value of PERTRB
C      should be small compared to the right side F.  Otherwise, a
C      solution is obtained to an essentially different problem.  This
C      comparison should always be made to insure that a meaningful
C      solution has been obtained.
C
C    IERROR
C      An error flag that indicates invalid input parameters.
C       Except for numbers 0 and  6, a solution is not attempted.
C
C      =  0  No error
C
C      =  1  A .GE. B
C
C      =  2  MBDCND .LT. 0 or MBDCND .GT. 4
C
C      =  3  C .GE. D
C
C      =  4  N .LE. 2
C
C      =  5  NBDCND .LT. 0 or NBDCND .GT. 4
C
C      =  6  LAMBDA .GT. 0
C
C      =  7  IDIMF .LT. M
C
C      =  8  M .LE. 2
C
C      Since this is the only means of indicating a possibly
C      incorrect call to HSTCRT, the user should test IERROR after
C      the call.
C
C    W
C      W(1) contains the required length of W.
C
C *Long Description:
C
C     * * * * * * *   Program Specifications    * * * * * * * * * * * *
C
C     Dimension of   BDA(N),BDB(N),BDC(M),BDD(M),F(IDIMF,N),
C     Arguments      W(See argument list)
C
C     Latest         June 1, 1977
C     Revision
C
C     Subprograms    HSTCRT,POISTG,POSTG2,GENBUN,POISD2,POISN2,POISP2,
C     Required       COSGEN,MERGE,TRIX,TRI3,PIMACH
C
C     Special        NONE
C     Conditions
C
C     Common         NONE
C     Blocks
C
C     I/O            NONE
C
C     Precision      Single
C
C     Specialist     Roland Sweet
C
C     Language       FORTRAN
C
C     History        Written by Roland Sweet at NCAR in January , 1977
C
C     Algorithm      This subroutine defines the finite-difference
C                    equations, incorporates boundary data, adjusts the
C                    right side when the system is singular and calls
C                    either POISTG or GENBUN which solves the linear
C                    system of equations.
C
C     Space          8131(decimal) = 17703(octal) locations on the
C     Required       NCAR Control Data 7600
C
C     Timing and        The execution time T on the NCAR Control Data
C     Accuracy       7600 for subroutine HSTCRT is roughly proportional
C                    to M*N*log2(N).  Some typical values are listed in
C                    the table below.
C                       The solution process employed results in a loss
C                    of no more than FOUR significant digits for N and M
C                    as large as 64.  More detailed information about
C                    accuracy can be found in the documentation for
C                    subroutine POISTG which is the routine that
C                    actually solves the finite difference equations.
C
C
C                       M(=N)    MBDCND    NBDCND    T(MSECS)
C                       -----    ------    ------    --------
C
C                        32       1-4       1-4         56
C                        64       1-4       1-4        230
C
C     Portability    American National Standards Institute Fortran.
C                    The machine dependent constant PI is defined in
C                    function PIMACH.
C
C     Required       COS
C     Resident
C     Routines
C
C     Reference      Schumann, U. and R. Sweet,'A Direct Method For
C                    The Solution Of Poisson's Equation With Neumann
C                    Boundary Conditions On A Staggered Grid Of
C                    Arbitrary Size,' J. COMP. PHYS. 20(1976),
C                    PP. 171-182.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C***REFERENCES  U. Schumann and R. Sweet, A direct method for the
C                 solution of Poisson's equation with Neumann boundary
C                 conditions on a staggered grid of arbitrary size,
C                 Journal of Computational Physics 20, (1976),
C                 pp. 171-182.
C***ROUTINES CALLED  GENBUN, POISTG
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  HSTCRT
C
C
      DIMENSION       F(IDIMF,*) ,BDA(*)     ,BDB(*)     ,BDC(*)     ,
     1                BDD(*)     ,W(*)
C***FIRST EXECUTABLE STATEMENT  HSTCRT
      IERROR = 0
      IF (A .GE. B) IERROR = 1
      IF (MBDCND.LT.0 .OR. MBDCND.GT.4) IERROR = 2
      IF (C .GE. D) IERROR = 3
      IF (N .LE. 2) IERROR = 4
      IF (NBDCND.LT.0 .OR. NBDCND.GT.4) IERROR = 5
      IF (IDIMF .LT. M) IERROR = 7
      IF (M .LE. 2) IERROR = 8
      IF (IERROR .NE. 0) RETURN
      NPEROD = NBDCND
      MPEROD = 0
      IF (MBDCND .GT. 0) MPEROD = 1
      DELTAX = (B-A)/M
      TWDELX = 1./DELTAX
      DELXSQ = 2./DELTAX**2
      DELTAY = (D-C)/N
      TWDELY = 1./DELTAY
      DELYSQ = DELTAY**2
      TWDYSQ = 2./DELYSQ
      NP = NBDCND+1
      MP = MBDCND+1
C
C     DEFINE THE A,B,C COEFFICIENTS IN W-ARRAY.
C
      ID2 = M
      ID3 = ID2+M
      ID4 = ID3+M
      S = (DELTAY/DELTAX)**2
      ST2 = 2.*S
      DO 101 I=1,M
         W(I) = S
         J = ID2+I
         W(J) = -ST2+ELMBDA*DELYSQ
         J = ID3+I
         W(J) = S
  101 CONTINUE
C
C     ENTER BOUNDARY DATA FOR X-BOUNDARIES.
C
      GO TO (111,102,102,104,104),MP
  102 DO 103 J=1,N
         F(1,J) = F(1,J)-BDA(J)*DELXSQ
  103 CONTINUE
      W(ID2+1) = W(ID2+1)-W(1)
      GO TO 106
  104 DO 105 J=1,N
         F(1,J) = F(1,J)+BDA(J)*TWDELX
  105 CONTINUE
      W(ID2+1) = W(ID2+1)+W(1)
  106 GO TO (111,107,109,109,107),MP
  107 DO 108 J=1,N
         F(M,J) = F(M,J)-BDB(J)*DELXSQ
  108 CONTINUE
      W(ID3) = W(ID3)-W(1)
      GO TO 111
  109 DO 110 J=1,N
         F(M,J) = F(M,J)-BDB(J)*TWDELX
  110 CONTINUE
      W(ID3) = W(ID3)+W(1)
  111 CONTINUE
C
C     ENTER BOUNDARY DATA FOR Y-BOUNDARIES.
C
      GO TO (121,112,112,114,114),NP
  112 DO 113 I=1,M
         F(I,1) = F(I,1)-BDC(I)*TWDYSQ
  113 CONTINUE
      GO TO 116
  114 DO 115 I=1,M
         F(I,1) = F(I,1)+BDC(I)*TWDELY
  115 CONTINUE
  116 GO TO (121,117,119,119,117),NP
  117 DO 118 I=1,M
         F(I,N) = F(I,N)-BDD(I)*TWDYSQ
  118 CONTINUE
      GO TO 121
  119 DO 120 I=1,M
         F(I,N) = F(I,N)-BDD(I)*TWDELY
  120 CONTINUE
  121 CONTINUE
      DO 123 I=1,M
         DO 122 J=1,N
            F(I,J) = F(I,J)*DELYSQ
  122    CONTINUE
  123 CONTINUE
      IF (MPEROD .EQ. 0) GO TO 124
      W(1) = 0.
      W(ID4) = 0.
  124 CONTINUE
      PERTRB = 0.
      IF (ELMBDA) 133,126,125
  125 IERROR = 6
      GO TO 133
  126 GO TO (127,133,133,127,133),MP
  127 GO TO (128,133,133,128,133),NP
C
C     FOR SINGULAR PROBLEMS MUST ADJUST DATA TO INSURE THAT A SOLUTION
C     WILL EXIST.
C
  128 CONTINUE
      S = 0.
      DO 130 J=1,N
         DO 129 I=1,M
            S = S+F(I,J)
  129    CONTINUE
  130 CONTINUE
      PERTRB = S/(M*N)
      DO 132 J=1,N
         DO 131 I=1,M
            F(I,J) = F(I,J)-PERTRB
  131    CONTINUE
  132 CONTINUE
      PERTRB = PERTRB/DELYSQ
C
C     SOLVE THE EQUATION.
C
  133 CONTINUE
      IF (NPEROD .EQ. 0) GO TO 134
      CALL POISTG (NPEROD,N,MPEROD,M,W(1),W(ID2+1),W(ID3+1),IDIMF,F,
     1             IERR1,W(ID4+1))
      GO TO 135
  134 CONTINUE
      CALL GENBUN (NPEROD,N,MPEROD,M,W(1),W(ID2+1),W(ID3+1),IDIMF,F,
     1             IERR1,W(ID4+1))
  135 CONTINUE
      W(1) = W(ID4+1)+3*M
      RETURN
      END


submodule(euler_interface_m) euler_prob_0033_m
    implicit none

contains

    module character(len=20) function euler0033()
        write (euler0033, "(i20)") ans()
    end function euler0033

    integer function ans()
        integer :: c, d, n, dp, np

        c = 1; d = 1; n = 1
        np = 1; dp = 1

        do c = 1, 9
            do d = 1, c - 1
                do n = 1, d - 1
                    if ((n*10 + c)*d == (c*10 + d)*n) then
                        np = np*n
                        dp = dp*d
                    end if
                end do
            end do
        end do
        ans = dp/gcd(np, dp)
    end function ans

end submodule euler_prob_0033_m


c
c-----------------------------------------------------------------------
c
      subroutine p20fn(xcen,ycen,q,time)
      implicit double precision(a-h,o-z)
      dimension q(1)
c
c     # For the point (x,y), compute the true solution at this point
c
       xshift = 1.5
       yshift = 1.5
       pi = 3.14159265357989d0

       yuse = ycen - yshift
       xuse = xcen - xshift
       radius = dsqrt(yuse**2+xuse**2)
       sr     = 2.d0*pi/5.d0   ! goes around one full circle in 5 time units

       theta  = atan2(yuse,xuse)

       thetause = theta - sr*time
       xinit = cos(thetause)
       yinit = sin(thetause)

       thetainit = atan2(yinit,xinit)

       w = .5d0*( erf((pi/6.d0-thetainit)/sqrt(4.d0/100.d0)) +
     &            erf((pi/6.d0+thetainit)/sqrt(4.d0/100.d0)) )

c      theta = atan2(ycen-yshift,xcen-xshift)
c      w = .5d0*( erf((pi/6.d0-theta)/sqrt(4.d0/100.d0)) +
c    &            erf((pi/6.d0+theta)/sqrt(4.d0/100.d0)) )

       q(1) = w
c      q(1) = 1.0
c   stick in prob 16 into prob 20
c        q(1) = ycen - .1*xcen + .5

       return
       end


program main
    implicit none
    integer, parameter :: dp = selected_real_kind(8)
    real(dp), parameter :: pi = acos(-1.d0), NA = 6.02214076d23, kB = 1.380649d-23
    integer(1) :: i
    real(dp) :: T(7) = (/.1d0, 1.d0, 5.d0, 8.d0, 10.d0, 15.d0, 20.d0/)
    real(dp) :: C(7) = (/8.5d-7, 8.6d-4, 1.2d-1, 5.9d-1, 1.1d0, 2.8d0, 6.3d0/)
    real(dp) :: TTSum = 0.d0, TCSum = 0.d0, result

    T = T**3
    do i = 1,7
        TTSum = TTSum + T(i)**2
        TCSum = TCSum + T(i) * C(i)
    end do
    result = (12 * pi**4 * NA * kB / (5 * (TCSum / TTSum)))**(1.d0/3.d0)
    write(*,*) result
end program main


SUBROUTINE p74(input_file,output_file)
!-------------------------------------------------------------------------
! SUBROUTINE 7.4 General two- (plane) or three-dimensional analysis of steady
!             seepage.
!-------------------------------------------------------------------------
 USE main;
 USE geom;
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::fixed_freedoms,i,iel,k,loaded_nodes,nci,ndim,nels,neq,nip,nlen, &
   nod,nn,np_types;
   CHARACTER(LEN=15)::argv,element
 REAL(iwp)::det,penalty=1.0e20_iwp,zero=0.0_iwp
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g_num(:,:),kdiag(:),node(:),num(:)
 REAL(iwp),ALLOCATABLE::coord(:,:),der(:,:),deriv(:,:),disps(:),          &
   g_coord(:,:),jac(:,:),kay(:,:),kp(:,:),kv(:),kvh(:),loads(:),          &
   points(:,:),prop(:,:),value(:),weights(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file);
 OPEN(11,FILE=output_file)
 READ(10,*)element,nod,nels,nn,nip,ndim,np_types;
 neq=nn
 ALLOCATE(points(nip,ndim),g_coord(ndim,nn),coord(nod,ndim),etype(nels),  &
   jac(ndim,ndim),weights(nip),num(nod),g_num(nod,nels),der(ndim,nod),    &
   deriv(ndim,nod),kp(nod,nod),kay(ndim,ndim),prop(ndim,np_types),        &
   kdiag(neq),loads(0:neq),disps(0:neq))
 READ(10,*)prop;
 etype=1;
 IF(np_types>1)READ(10,*)etype
 READ(10,*)g_coord;
 READ(10,*)g_num
 IF(ndim==2)CALL mesh(g_coord,g_num,argv,nlen,12);
 kdiag=0
!-----------------------loop the elements to find global arrays sizes-----
 elements_1: DO iel =1,nels;
   num=g_num(:,iel);
   CALL fkdiag(kdiag,num)
 END DO elements_1
 DO i=2,neq;
   kdiag(i)=kdiag(i)+kdiag(i-1);
 END DO
 WRITE(11,'(2(A,I5))')                                                    &
  " There are",neq," equations and the skyline storage is",kdiag(neq)
 ALLOCATE(kv(kdiag(neq)),kvh(kdiag(neq)));
 kv=zero
 CALL sample(element,points,weights)
!-----------------------global conductivity matrix assembly---------------
 elements_2: DO iel=1,nels
   kay=zero;
   DO i=1,ndim;
     kay(i,i)=prop(i,etype(iel));
   END DO
   num=g_num(:,iel);
   coord=TRANSPOSE(g_coord(:,num));
   kp=zero
   gauss_pts_1: DO i=1,nip
     CALL shape_der(der,points,i);
     jac=MATMUL(der,coord)
     det=determinant(jac);
     CALL invert(jac);
     deriv=MATMUL(jac,der)
     kp=kp+MATMUL(MATMUL(TRANSPOSE(deriv),kay),deriv)*det*weights(i)
   END DO gauss_pts_1;
   CALL fsparv(kv,kp,num,kdiag)
 END DO elements_2;
 kvh=kv
!-----------------------specify boundary values---------------------------
 loads=zero;
 READ(10,*)loaded_nodes,(k,loads(k),i=1,loaded_nodes)
 READ(10,*)fixed_freedoms
 IF(fixed_freedoms/=0)THEN
   ALLOCATE(node(fixed_freedoms),value(fixed_freedoms))
   READ(10,*)(node(i),value(i),i=1,fixed_freedoms)
   kv(kdiag(node))=kv(kdiag(node))+penalty
   loads(node)=kv(kdiag(node))*value
 END IF
!-----------------------equation solution---------------------------------
 CALL sparin(kv,kdiag);
 CALL spabac(kv,loads,kdiag)
!-----------------------retrieve nodal net flow rates---------------------
 CALL linmul_sky(kvh,loads,disps,kdiag)
 WRITE(11,'(/A)')"  Node Total Head  Flow rate"
 DO k=1,nn;
   WRITE(11,'(I5,2E12.4)')k,loads(k),disps(k);
 END DO
 disps(0)=zero;
 WRITE(11,'(/A)')"       Inflow      Outflow"
 WRITE(11,'(5X,2E12.4)')                                                  &
   SUM(disps,MASK=disps>zero),SUM(disps,MASK=disps<zero)
 IF(ndim==2.AND.nod==4)THEN
   READ(10,*)nci;
   CALL contour(loads,g_coord,g_num,nci,argv,nlen,13)
 END IF

END SUBROUTINE p74


module functions_module
   implicit none
   private ! all by default
   public :: f,g

contains

   pure function  f(x)
      implicit none
      real, intent(in) :: x
      real :: f
      f = sin(x)
   end function f

   pure function  g(x)
      implicit none
      real, intent(in) :: x
      real :: g
      g = cos(x)
   end function g

end module functions_module

module compose_module
   implicit none
   private ! all by default
   public :: compose

   interface
      pure function  f(x)
         implicit none
         real, intent(in) :: x
         real :: f
      end function f

      pure function  g(x)
         implicit none
         real, intent(in) :: x
         real :: g
      end function g
   end interface

contains

   impure function  compose(x, fi, gi)
      implicit none
      real, intent(in) :: x
      procedure(f), optional :: fi
      procedure(g), optional :: gi
      real :: compose

      procedure (f), pointer, save :: fpi => null()
      procedure (g), pointer, save :: gpi => null()

      if(present(fi) .and. present(gi))then
         fpi => fi
         gpi => gi
         compose = 0
         return
      endif

      if(.not. associated(fpi)) error stop "fpi"
      if(.not. associated(gpi)) error stop "gpi"

      compose = fpi(gpi(x))

   contains

   end function compose

end module compose_module

program test_compose
   use functions_module
   use compose_module
   implicit none
   write(*,*) "prepare compose:", compose(0.0, f,g)
   write(*,*) "run compose:", compose(0.5)
end program test_compose


C ****************************************************************************
C  FILE: mpi_pi_reduce.f
C  DESCRIPTION:
C    MPI pi Calculation Example - Fortran Version
C    Collective Communications examples
C    This program calculates pi using a "dartboard" algorithm.  See
C    Fox et al.(1988) Solving Problems on Concurrent Processors, vol.1
C    page 207.  All processes contribute to the calculation, with the
C    master averaging the values for pi. SPMD Version:  Conditional
C    statements check if the process is the master or a worker.
C    This version uses mp_reduce to collect results
C    Note: Requires Fortran90 compiler due to random_number() function
C  AUTHOR: Blaise Barney. Adapted from Ros Leibensperger, Cornell Theory
C    Center. Converted to MPI: George L. Gusciora, MHPCC (1/95)
C  LAST REVISED: 06/13/13 Blaise Barney
C ****************************************************************************
C Explanation of constants and variables used in this program:
C   DARTS          = number of throws at dartboard
C   ROUNDS         = number of times "DARTS" is iterated
C   MASTER         = task ID of master task
C   taskid         = task ID of current task
C   numtasks       = number of tasks
C   homepi         = value of pi calculated by current task
C   pisum          = sum of tasks' pi values
C   pi 	           = average of pi for this iteration
C   avepi          = average pi value for all iterations
C   seednum        = seed number - based on taskid

      program pi_reduce
      include 'mpif.h'

      integer DARTS, ROUNDS, MASTER
      parameter(DARTS = 5000)
      parameter(ROUNDS = 100)
      parameter(MASTER = 0)

      integer 	taskid, numtasks, i, status(MPI_STATUS_SIZE)
      real*4	seednum
      real*8 	homepi, pi, avepi, pisum, dboard
      external  d_vadd

C     Obtain number of tasks and task ID
      call MPI_INIT( ierr )
      call MPI_COMM_RANK( MPI_COMM_WORLD, taskid, ierr )
      call MPI_COMM_SIZE( MPI_COMM_WORLD, numtasks, ierr )
      write(*,*)'task ID = ', taskid

      avepi = 0

      do 40 i = 1, ROUNDS
C     Calculate pi using dartboard algorithm
        homepi = dboard(DARTS)

C     Use mp_reduce to sum values of homepi across all tasks
C     Master will store the accumulated value in pisum
C     - homepi is the send buffer
C     - pisum is the receive buffer (used by the receiving task only)
C     - MASTER is the task that will receive the result of the reduction
C       operation
C     - d_vadd is a pre-defined reduction function (double-precision
C       floating-point vector addition)
C     - allgrp is the group of tasks that will participate
        call MPI_REDUCE( homepi, pisum, 1, MPI_DOUBLE_PRECISION,
     &                   MPI_SUM, MASTER, MPI_COMM_WORLD, ierr )
C     Master computes average for this iteration and all iterations
        if (taskid .eq. MASTER) then
          pi = pisum/numtasks
          avepi = ((avepi*(i-1)) + pi) / i
          write(*,32) DARTS*i, avepi
 32       format('   After',i6,' throws, average value of pi = ',f10.8)
        endif
 40   continue

      if (taskid .eq. MASTER) then
        print *, ' '
        print *,'Real value of PI: 3.1415926535897'
        print *, ' '
      endif

      call MPI_FINALIZE(ierr)

      end

C *****************************************************************************
C function dboard.f
C DESCRIPTION:
C   Used in pi calculation example codes.
C   See mpi_pi_send.f and mpi_pi_reduce.f
C   Throw darts at board.  Done by generating random numbers
C   between 0 and 1 and converting them to values for x and y
C   coordinates and then testing to see if they "land" in
C   the circle."  If so, score is incremented.  After throwing the
C   specified number of darts, pi is calculated.  The computed value
C   of pi is returned as the value of this function, dboard.
C   Note: Requires Fortran90 compiler due to random_number() function
C
C Explanation of constants and variables used in this function:
C   darts    	= number of throws at dartboard
C   score	= number of darts that hit circle
C   n		= index variable
C   r  		= random number between 0 and 1
C   x_coord	= x coordinate, between -1 and 1
C   x_sqr	= square of x coordinate
C   y_coord	= y coordinate, between -1 and 1
C   y_sqr	= square of y coordinate
C   pi		= computed value of pi
C **************************************************************************/

      real*8    function dboard(darts)
      integer   darts, score, n
      real*4	r
      real*8	x_coord, x_sqr, y_coord, y_sqr, pi

      score = 0

C     "throw darts at the board"
      do 10 n = 1, darts
C     generate random numbers for x and y coordinates
        call random_number(r)
        x_coord = (2.0 * r) - 1.0
	x_sqr = x_coord * x_coord

        call random_number(r)
        y_coord = (2.0 * r) - 1.0
	y_sqr = y_coord * y_coord

C       if dart lands in circle, increment score
	if ((x_sqr + y_sqr) .le. 1.0) then
	  score = score + 1
        endif

 10   continue

C     calculate pi
      pi = 4.0 * score / darts
      dboard = pi
      end


      PROGRAM xrank
C     driver for routine rank
      INTEGER i,j,k,l,indx(100),irank(100)
      REAL a(100),b(10)
      open(7,file='TARRAY.DAT',status='OLD')
      read(7,*) (a(i),i=1,100)
      close(7)
      call indexx(100,a,indx)
      call rank(100,indx,irank)
      write(*,*) 'Original array is:'
      do 11 i=1,10
        write(*,'(1x,10f7.2)') (a(10*(i-1)+j), j=1,10)
11    continue
      write(*,*) 'Table of ranks is:'
      do 12 i=1,10
        write(*,'(1x,10i6)') (irank(10*(i-1)+j), j=1,10)
12    continue
      write(*,*) 'press RETURN to continue...'
      read(*,*)
      write(*,*) 'Array sorted according to rank table:'
      do 15 i=1,10
        do 14 j=1,10
          k=10*(i-1)+j
          do 13 l=1,100
            if (irank(l).eq.k) b(j)=a(l)
13        continue
14      continue
        write(*,'(1x,10f7.2)') (b(j),j=1,10)
15    continue
      END

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


      SUBROUTINE CROSSP (VX1,VY1,VZ1, VX2,VY2,VZ2, VX3,VY3,VZ3)

C  This subroutine accepts two 3D vectors and returns their
C  cross product.

      REAL  VX1,VY1,VZ1, VX2,VY2,VZ2, VX3,VY3,VZ3

      VX3 = VY1*VZ2 - VZ1*VY2
      VY3 = VZ1*VX2 - VX1*VZ2
      VZ3 = VX1*VY2 - VY1*VX2

      END


C  PSPLINE -- modified from SPLINE.FOR -- dmc 3 Oct 1995
C
C	THE CODES (SPLINE & SEVAL) ARE TAKEN FROM:
C	FORSYTHE,MALCOLM AND MOLER, "COMPUTER METHODS FOR
C	MATHEMATICAL COMPUTATIONS",PRENTICE-HALL, 1977.
c
c  PSPLINE -- periodic spline -- adaptation of SPLINE.FOR by D. McCune
c  October 1995:  The function to be splined is taken as having periodic
C  derivatives (it need not be periodic itself), so that
c  the interpolating function satisfies
c            y'(x(1))=y'(x(N))
c           y''(x(1))=y''(x(N))
c  this results in a fully specified system (no addl BC assumptions
c  required); it is not a tridiagonal system but a modified NM1xNM1
c  tridiagonal system with non-zero offdiagonal corner (1,NM1), (NM1,1)
c  elements.  It remains symmetric & diagonally dominant, and is
c  solved by Gaussian elimination w/o pivoting.  NM1=N-1.
c
      SUBROUTINE PSPLINE (N, X, Y, B, C, D, WK)
      INTEGER N
      REAL X(N), Y(N), B(N), C(N), D(N), WK(N)
C
C  THE COEFFICIENTS B(I), C(I), AND D(I), I=1,2,...,N ARE COMPUTED
C  FOR A periodic CUBIC INTERPOLATING SPLINE
C
C    S(X) = Y(I) + B(I)*(X-X(I)) + C(I)*(X-X(I))**2 + D(I)*(X-X(I))**3
C
C    FOR  X(I) .LE. X .LE. X(I+1)
C
C    WK(...) is used as a workspace during the Guassian elimination.
C    it represents the rightmost column of the array
C
C    note B(N),C(N),D(N) give coeffs for a periodic continuation into
C    the next period, up to X(N)+(X(2)-X(1)) only.
C
C    SEVAL can be used to evaluate the spline, but, it is up to the
C    SEVAL caller to bring the argument into the normal range X(1) to X(N).
C
C  INPUT..
C
C    N = THE NUMBER OF DATA POINTS OR KNOTS (N.GE.2)
C        includes a complete period of the data, the last point being
C        a repeat of the first point.
C    X = THE ABSCISSAS OF THE KNOTS IN STRICTLY INCREASING ORDER
C        X(N)-X(1) is the period of the periodic function represented.
C    Y = THE ORDINATES OF THE KNOTS
C
C  OUTPUT..
C
C    B, C, D  = ARRAYS OF SPLINE COEFFICIENTS AS DEFINED ABOVE.
C
C  USING  P  TO DENOTE DIFFERENTIATION,
C
C    Y(I) = S(X(I))
C    B(I) = SP(X(I))
C    C(I) = SPP(X(I))/2
C    D(I) = SPPP(X(I))/6  (DERIVATIVE FROM THE RIGHT)
C
CCCCCCCCCCCCCCC
C  THE ACCOMPANYING FUNCTION SUBPROGRAM  SEVAL  CAN BE USED
C  TO EVALUATE THE SPLINE.
C
C
      INTEGER NM1, NM2, IB, I
      REAL T
C
C-------------------------------------
C
      NM1 = N-1
      NM2 = NM1-1
C
      IF ( N .LT. 4 ) THEN
         write(6,9901)
 9901    format(/
     >   ' ?PSPLINE -- at least 4 pts required for periodic spline.')
         return
      ENDIF
C
C  SET UP MODIFIED NM1 x NM1 TRIDIAGONAL SYSTEM:
C  B = DIAGONAL, D = OFFDIAGONAL, C = RIGHT HAND SIDE.
C  WK(1:NM2) = rightmost column above diagonal
C  WK(NM1)   = lower left corner element
C
      D(1) = X(2) - X(1)
      D(NM1) = X(N) - X(NM1)
      B(1) = 2.0*(D(1)+D(NM1))
      C(1) = (Y(N) - Y(NM1))/D(NM1)
      C(2) = (Y(2) - Y(1))/D(1)
      C(1) = C(2) - C(1)
      WK(1) = D(NM1)
      DO 10 I = 2, NM1
         D(I) = X(I+1) - X(I)
         B(I) = 2.*(D(I-1) + D(I))
         C(I+1) = (Y(I+1) - Y(I))/D(I)
         C(I) = C(I+1) - C(I)
         WK(I) = 0.0
   10 CONTINUE
      WK(NM2) = D(NM2)
      WK(NM1) = D(NM1)
C
C  END CONDITIONS -- implied by periodicity
C     C(1)=C(N)  B(1)=B(N)  D(1)=D(N) -- no additional assumption needed.
C
C  FORWARD ELIMINATION
C   WK(1)--WK(NM2) represent the rightmost column above the
C   diagonal; WK(NM1) represents the non-zero lower left corner element
C   which in each step is moved one column to the right.
C
   15 DO 20 I = 2, NM2
         T = D(I-1)/B(I-1)
         B(I) = B(I) - T*D(I-1)
         C(I) = C(I) - T*C(I-1)
         WK(I) = WK(I) - T*WK(I-1)
         Q = WK(NM1)/B(I-1)
         WK(NM1) = -Q*D(I-1)
         B(NM1) = B(NM1) - Q*WK(I-1)
         C(NM1) = C(NM1) - Q*C(I-1)
   20 CONTINUE
C
C  correct the (NM1,NM2) element
C
      WK(NM1) = WK(NM1) + D(NM2)
C
C  complete the forward elimination:  now WK(NM1) and WK(NM2) are
C  the off diagonal elements of the 2x2 at the lower right hand corner
C
      T = WK(NM1)/B(NM2)
      B(NM1) = B(NM1) - T*WK(NM2)
      C(NM1) = C(NM1) - T*C(NM2)
C
C  BACK SUBSTITUTION
C
      C(NM1) = C(NM1)/B(NM1)
      C(NM2) = (C(NM2) - WK(NM2)*C(NM1))/B(NM2)
C
      DO 30 IB = 3, NM1
         I = N-IB
         C(I) = (C(I) - D(I)*C(I+1) - WK(I)*C(NM1))/B(I)
   30 CONTINUE
C
C  PERIODICITY:
C
      C(N)=C(1)
C
C  C(I) IS NOW THE SIGMA(I) OF THE TEXT
C
C  COMPUTE POLYNOMIAL COEFFICIENTS
C
      DO 40 I = 1, NM1
         B(I) = (Y(I+1) - Y(I))/D(I) - D(I)*(C(I+1) + 2.*C(I))
         D(I) = (C(I+1) - C(I))/D(I)
         C(I) = 3.*C(I)
   40 CONTINUE
C periodic continuation...
      B(N) = B(1)
      C(N) = C(1)
      D(N) = D(1)
C
      RETURN
      END


subroutine smth(var, nx, ny, var_smth)

  use types, only : wp
  use params, only : nsmth_x, nsmth_y, nx1, nx2, ny1, ny2

  implicit none

  integer    , intent(in) :: nx
  integer    , intent(in) :: ny
  real   (wp), intent(in) :: var     (0:nx,       0:ny)
  real   (wp), intent(out):: var_smth(nx1:nx2, ny1:ny2)
  ! Local variables
  real   (wp)             :: tmp     (nx1:nx2, ny1:ny2)
  integer                 :: nc
  integer                 :: i, j, ii, jj
  real   (wp), parameter  :: var_thresh = -10.0

  var_smth(nx1:nx2, ny1:ny2) = var(nx1:nx2, ny1:ny2)

  do j = ny1, ny2
    do i = nx1, nx2
      nc = 0
      tmp(i, j) = 0.
      if (var(i, j) > var_thresh) then
        do jj = max(-nsmth_y, -j), min(nsmth_y, ny-j)
          do ii = max(-nsmth_x, -i), min(nsmth_x, nx-i)
            if (var(i+ii, j+jj) > var_thresh) then
              tmp(i, j) = tmp(i, j) + var(i+ii, j+jj)
              nc = nc + 1
            endif
          enddo
        enddo
        tmp(i, j) = tmp(i, j) / ((2 * nsmth_x + 1) * (2 * nsmth_y + 1))
        var_smth(i, j) = tmp(i, j)
      endif
    enddo
  enddo
end subroutine smth

subroutine smth_r(var, nx, ny, lon, lat, var_smth)

  use types, only : wp
  use constants, only : pi, ra, rkilo, deg2rad
  use params, only : proj, r_smth, nx1, nx2, ny1, ny2
  use utils, only : great_circle, cosd

  implicit none

  integer    , intent(in) :: nx
  integer    , intent(in) :: ny
  real   (wp), intent(in) :: var     (0:nx,       0:ny)
  real   (wp), intent(in) :: lon     (0:nx            )
  real   (wp), intent(in) :: lat     (            0:ny)
  real   (wp), intent(out):: var_smth(nx1:nx2, ny1:ny2)
  ! Local variables
  real   (wp)             :: tmp     (nx1:nx2, ny1:ny2)
  integer                 :: nc
  integer                 :: i, j, ii, jj
  real   (wp)             :: lonin, latin
  integer                 :: x_smth, y_smth
  real   (wp)             :: dist
  real   (wp), parameter  :: var_thresh = -10.0 ! TODO: replace by fillval?

  x_smth = 0
  y_smth = 0

  dist = 0.

  lonin = lon(2) - lon(1)
  latin = lat(2) - lat(1)

  if (proj==1) then
    x_smth = nint(r_smth / (ra * lonin * deg2rad * cosd(lat(ny1+ny2/2)) / rkilo)) + 1
    y_smth = nint(r_smth / (ra * latin * deg2rad / rkilo)) + 1
  elseif (proj==2) then
    x_smth = nint(r_smth / lonin / rkilo) + 2
    y_smth = nint(r_smth / latin / rkilo) + 2 ! TODO: check why +2
  endif

  ! print*, x_smth, y_smth

  var_smth(nx1:nx2, ny1:ny2) = var(nx1:nx2, ny1:ny2)

  do j = ny1, ny2
  !  if (j - y_smth >= 0 .and. j + y_smth <= ny) then
      do i = nx1, nx2
  !      if (i - x_smth >= 0 .and. i + x_smth <= nx) then
          nc = 0
          tmp(i, j) = 0.
          if (var(i, j) > var_thresh) then
            do jj = max(-y_smth, -j), min(y_smth, ny-j)
              do ii = max(-x_smth, -i), min(x_smth, nx-i)
                if (proj == 1) then
                  dist = great_circle(lon(i), lon(i+ii), lat(j), lat(j+jj), ra)
                elseif(proj==2)then
                  dist = sqrt((ii * lonin)**2 + (jj * latin)**2)
                endif

                if (dist <= r_smth * rkilo) then
                  if (var(i+ii, j+jj) > var_thresh) then
                    nc = nc + 1
                    tmp(i, j) = tmp(i, j) + var(i+ii, j+jj)
                  endif
                endif
              enddo
            enddo
            var_smth(i, j) = tmp(i, j) / nc
          endif
  !      endif
      enddo
  !  endif
  enddo
end subroutine smth_r


module ChemicalSystem
    implicit none

    integer(kind=4), parameter                  :: num_reactions = 9
    integer(kind=4), parameter                  :: num_species   = 5
    integer(kind=4), parameter, dimension(5,9)  :: nu = reshape((/ -2, 1, 0, 0, 0, 2, -1, 0, 0, 0, 0, -1, -1, 1, 0, 0, 1, 1, -1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, -1, 0, 0, 0, 0, 0, 0, 0, 0, -1 /),(/5,9/))
       real(kind=8), dimension(5)               :: X0 = (/ 10, 0, 20, 0, 0 /)
       real(kind=8), dimension(9)               :: c = (/ 50, 1000, 50, 1000, 1, 10, 3, 1, 6 /)

    contains

    function propensities(X) result(a)
        real(kind=8), dimension(num_species), intent(in) :: X
        real(kind=8), dimension(num_reactions)           :: a

        a(1) = c(1) * 0.5d0 * X(1) * (X(1)-1)
        a(2) = c(2) * X(2)
        a(3) = c(3) * X(2) * X(3)
        a(4) = c(4) * X(4)
        a(5) = c(5) * X(3)
        a(6) = c(6) * X(4)
        a(7) = c(7) * X(5)
        a(8) = c(8) * X(1)
        a(9) = c(9) * X(5)
    end function

    function propJacobian(X) result(Ja)
        real(kind=8), dimension(num_species), intent(in)   :: X
        real(kind=8), dimension(num_reactions,num_species) :: Ja

        Ja(1,1) = c(1) * 0.5d0 * ( 2*X(1) - 1 )
        Ja(2,1) = 0
        Ja(3,1) = 0
        Ja(4,1) = 0
        Ja(5,1) = 0
        Ja(6,1) = 0
        Ja(7,1) = 0
        Ja(8,1) = c(8)
        Ja(9,1) = 0
        Ja(1,2) = 0
        Ja(2,2) = c(2)
        Ja(3,2) = c(3) * X(3)
        Ja(4,2) = 0
        Ja(5,2) = 0
        Ja(6,2) = 0
        Ja(7,2) = 0
        Ja(8,2) = 0
        Ja(9,2) = 0
        Ja(1,3) = 0
        Ja(2,3) = 0
        Ja(3,3) = c(3) * X(2)
        Ja(4,3) = 0
        Ja(5,3) = c(5)
        Ja(6,3) = 0
        Ja(7,3) = 0
        Ja(8,3) = 0
        Ja(9,3) = 0
        Ja(1,4) = 0
        Ja(2,4) = 0
        Ja(3,4) = 0
        Ja(4,4) = c(4)
        Ja(5,4) = 0
        Ja(6,4) = c(6)
        Ja(7,4) = 0
        Ja(8,4) = 0
        Ja(9,4) = 0
        Ja(1,5) = 0
        Ja(2,5) = 0
        Ja(3,5) = 0
        Ja(4,5) = 0
        Ja(5,5) = 0
        Ja(6,5) = 0
        Ja(7,5) = c(7)
        Ja(8,5) = 0
        Ja(9,5) = c(9)
    end function

    function relaxRates(X) result(lambda)
        real(kind=8), dimension(num_species), intent(in) :: X
        real(kind=8), dimension(num_reactions)           :: lambda

        lambda(1) =  + c(1) * (2*X(1)-1) + c(2)
        lambda(2) =  + c(1) * (2*X(1)-1) + c(2)
        lambda(3) =  + c(3) * X(3) + c(3) * X(2) + c(4)
        lambda(4) =  + c(3) * X(3) + c(3) * X(2) + c(4)
        lambda(5) = c(5)
        lambda(6) = c(6)
        lambda(7) = c(7)
        lambda(8) =  + c(8)
        lambda(9) =  + c(9)
    end function
end module ChemicalSystem


!                                             29/04/2021
!-------------------------------------------------------!
module random
real, private             :: zero = 0.0, half = 0.5, one = 1.0, two = 2.0
private                   :: integral
public                    :: init_random_seed, random_unif, random_Poisson

contains

subroutine init_random_seed()

     integer :: i, n, clock
     integer, dimension(:), allocatable :: seed

     call random_seed(size = n)
     allocate(seed(n))

     call system_clock(COUNT=clock)

     seed = clock + 37 * (/ (i - 1, i = 1, n) /)
     call random_seed(put = seed)

     deallocate(seed)

end subroutine

function random_unif(a,b) result(ans)

use my_init, only: wp => dp !for double precission constants

real(wp) :: a,b,y

 !call init_random_seed()
call random_number(y)

ans = a + y * (b - a)
end function

function random_Poisson(mu, first) result(ival)
!**********************************************************************
!     Translated to Fortran 90 by Alan Miller from:
!                           RANLIB
!
!     Library of Fortran Routines for Random Number Generation
!
!                    Compiled and Written by:
!
!                         Barry W. Brown
!                          James Lovato
!
!             Department of Biomathematics, Box 237
!             The University of Texas, M.D. Anderson Cancer Center
!             1515 Holcombe Boulevard
!             Houston, TX      77030
!
! This work was supported by grant CA-16672 from the National Cancer Institute.

!                    GENerate POIsson random deviate

!                            function

! Generates a single random deviate from a Poisson distribution with mean mu.

!                            Arguments

!     mu --> The mean of the Poisson distribution from which
!            a random deviate is to be generated.
!                              real mu

!                              Method

!     For details see:

!               Ahrens, J.H. and Dieter, U.
!               Computer Generation of Poisson Deviates
!               From Modified Normal Distributions.
!               ACM Trans. Math. Software, 8, 2
!               (June 1982),163-179

!     TABLES: COEFFICIENTS A0-A7 FOR STEP F. FACTORIALS FACT
!     COEFFICIENTS A(K) - FOR PX = FK*V*V*SUM(A(K)*V**K)-DEL

!     SEPARATION OF CASES A AND B

!     .. Scalar Arguments ..
real, intent(in)    :: mu
logical, intent(in) :: first
integer             :: ival
!     ..
!     .. Local Scalars ..
real          :: b1, b2, c, c0, c1, c2, c3, del, difmuk, e, fk, fx, fy, g,  &
                 omega, px, py, t, u, v, x, xx
real, save    :: s, d, p, q, p0
integer       :: j, k, kflag
logical, save :: full_init
integer, save :: l, m
!     ..
!     .. Local Arrays ..
real, save    :: pp(35)
!     ..
!     .. Data statements ..
real, parameter :: a0 = -.5, a1 = .3333333, a2 = -.2500068, a3 = .2000118,  &
                   a4 = -.1661269, a5 = .1421878, a6 = -.1384794,   &
                   a7 = .1250060

real, parameter :: fact(10) = (/ 1., 1., 2., 6., 24., 120., 720., 5040.,  &
                                 40320., 362880. /)

!     ..
!     .. Executable Statements ..
if (mu > 10.0) then
!     C A S E  A. (RECALCULATION OF S, D, L if MU HAS CHANGED)

  if (first) then
    s = SQRT(mu)
    d = 6.0*mu*mu

!             THE POISSON PROBABILITIES PK EXCEED THE DISCRETE NORMAL
!             PROBABILITIES FK WHENEVER K >= M(MU). L=IFIX(MU-1.1484)
!             IS AN UPPER BOUND TO M(MU) FOR ALL MU >= 10 .

    l = mu - 1.1484
    full_init = .false.
  end if

!     STEP N. NORMAL SAMPLE - random_normal() FOR STANDARD NORMAL DEVIATE

  g = mu + s*random_normal()
  if (g > 0.0) then
    ival = g

!     STEP I. IMMEDIATE ACCEPTANCE if ival IS LARGE ENOUGH

    if (ival>=l) return

!     STEP S. SQUEEZE ACCEPTANCE - SAMPLE U

    fk = ival
    difmuk = mu - fk
    call random_number(u)
    if (d*u >= difmuk*difmuk*difmuk) return
  end if

!     STEP P. PREPARATIONS FOR STEPS Q AND H.
!             (RECALCULATIONS OF PARAMETERS if NECESSARY)
!             .3989423=(2*PI)**(-.5)  .416667E-1=1./24.  .1428571=1./7.
!             THE QUANTITIES B1, B2, C3, C2, C1, C0 ARE FOR THE HERMITE
!             APPROXIMATIONS TO THE DISCRETE NORMAL PROBABILITIES FK.
!             C=.1069/MU GUARANTEES MAJORIZATION BY THE 'HAT'-function.

  if (.NOT. full_init) then
    omega = .3989423/s
    b1 = .4166667E-1/mu
    b2 = .3*b1*b1
    c3 = .1428571*b1*b2
    c2 = b2 - 15.*c3
    c1 = b1 - 6.*b2 + 45.*c3
    c0 = 1. - b1 + 3.*b2 - 15.*c3
    c = .1069/mu
    full_init = .true.
  end if

  if (g < 0.0) goto 50

!             'SUBROUTINE' F IS CALLED (KFLAG=0 FOR CORRECT return)

  kflag = 0
  goto 70

!     STEP Q. QUOTIENT ACCEPTANCE (RARE CASE)

  40 if (fy-u*fy <= py*EXP(px-fx)) return

!     STEP E. EXPONENTIAL SAMPLE - random_exponential() FOR STANDARD EXPONENTIAL
!             DEVIATE E AND SAMPLE T FROM THE LAPLACE 'HAT'
!             (if T <= -.6744 then PK < FK FOR ALL MU >= 10.)

  50 e = random_exp(1.0)
  call random_number(u)
  u = u + u - one
  t = 1.8 + SIGN(e, u)
  if (t <= (-.6744)) goto 50
  ival = mu + s*t
  fk = ival
  difmuk = mu - fk

!             'SUBROUTINE' F IS CALLED (KFLAG=1 FOR CORRECT return)

  kflag = 1
  goto 70

!     STEP H. HAT ACCEPTANCE (E IS REPEATED ON REJECTION)

  60 if (c*ABS(u) > py*EXP(px+e) - fy*EXP(fx+e)) goto 50
  return

!     STEP F. 'SUBROUTINE' F. CALCULATION OF PX, PY, FX, FY.
!             CASE ival < 10 USES FACTORIALS FROM TABLE FACT

  70 if (ival>=10) goto 80
  px = -mu
  py = mu**ival/fact(ival+1)
  goto 110

!             CASE ival >= 10 USES POLYNOMIAL APPROXIMATION
!             A0-A7 FOR ACCURACY WHEN ADVISABLE
!             .8333333E-1=1./12.  .3989423=(2*PI)**(-.5)

  80 del = .8333333E-1/fk
  del = del - 4.8*del*del*del
  v = difmuk/fk
  if (ABS(v)>0.25) then
    px = fk*LOG(one + v) - difmuk - del
  else
    px = fk*v*v* (((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v+a0) - del
  end if
  py = .3989423/SQRT(fk)
  110 x = (half - difmuk)/s
  xx = x*x
  fx = -half*xx
  fy = omega* (((c3*xx + c2)*xx + c1)*xx + c0)
  if (kflag <= 0) goto 40
  goto 60

!---------------------------------------------------------------------------
!     C A S E  B.    mu < 10
!     START NEW TABLE AND CALCULATE P0 if NECESSARY

else
  if (first) then
    m = MAX(1, INT(mu))
    l = 0
    p = EXP(-mu)
    q = p
    p0 = p
  end if

!     STEP U. UNIFORM SAMPLE FOR INVERSION METHOD

  do
    call random_number(u)
    ival = 0
    if (u <= p0) return

!     STEP T. TABLE COMPARISON UNTIL THE end PP(L) OF THE
!             PP-TABLE OF CUMULATIVE POISSON PROBABILITIES
!             (0.458=PP(9) FOR MU=10)

    if (l == 0) goto 150
    j = 1
    if (u > 0.458) j = MIN(l, m)
    do k = j, l
      if (u <= pp(k)) goto 180
    end do
    if (l == 35) CYCLE

!     STEP C. CREATION OF NEW POISSON PROBABILITIES P
!             AND THEIR CUMULATIVES Q=PP(K)

    150 l = l + 1
    do k = l, 35
      p = p*mu / k
      q = q + p
      pp(k) = q
      if (u <= q) goto 170
    end do
    l = 35
  end do

  170 l = k
  180 ival = k
  return
end if

return
end function random_Poisson

! ------------------  Needed subroutines and functions -------------------!
real function random_exp(s)

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

! function GENERATES A RANDOM VARIATE IN [0,INFINITY) FROM
! A NEGATIVE EXPONENTIAL DlSTRIBUTION WlTH DENSITY PROPORTIONAL
! TO EXP(-random_exponential), USING INVERSION.

implicit none
real, intent(in)    :: s
!     Local variable
real  :: r

do
  call random_number(r)
  if (r > zero) exit
end do

random_exp = -log(r )/s
return

end function random_exp

real function random_normal()

! Adapted from the following Fortran 77 code
!      ALGORITHM 712, COLLECTED ALGORITHMS FROM ACM.
!      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
!      VOL. 18, NO. 4, DECEMBER, 1992, PP. 434-435.

!  The function random_normal() returns a normally distributed pseudo-random
!  number with zero mean and unit variance.

!  The algorithm uses the ratio of uniforms method of A.J. Kinderman
!  and J.F. Monahan augmented with quadratic bounding curves.

implicit none

!     Local variables
real     :: s = 0.449871, t = -0.386595, a = 0.19600, b = 0.25472,           &
            r1 = 0.27597, r2 = 0.27846, u, v, x, y, q

!     Generate P = (u,v) uniform in rectangle enclosing acceptance region

do
  call random_number(u)
  call random_number(v)
  v = 1.7156 * (v - half)

!     Evaluate the quadratic form
  x = u - s
  y = ABS(v) - t
  q = x**2 + y*(a*y - b*x)

!     Accept P if inside inner ellipse
  if (q < r1) exit
!     Reject P if outside outer ellipse
  if (q > r2) cycle
!     Reject P if outside acceptance region
  if (v**2 < -4.0*LOG(u)*u**2) exit
end do

!     Return ratio of P's coordinates as the normal deviate
random_normal = v/u
return

end function random_normal

subroutine random_stdgamma_alpha_ge_1(alpha,x)
  use my_init
   implicit none
   real,intent(in) :: alpha
   real,intent(out) :: x
   real :: y,t,u1,u2
   do
      u1 = random_unif(one,rero)
      !call random_stduniform(u1)
      y = -log(u1)
      t = (y/exp(y-1))**(alpha-1)
      u2 = random_unif(one,rero)
      if(u2 <= t) then
         x = alpha*y
         exit
      end if
   end do
end subroutine random_stdgamma_alpha_ge_1

subroutine random_stdgamma(alpha,x)
  use my_init
   implicit none
   real,intent(in) :: alpha
   real,intent(out) :: x
   real :: g,u
   if(alpha<=0) then
      stop "alpha<=0"
   else if(alpha<1) then
      call random_stdgamma_alpha_ge_1(alpha+1.0,g)
      !call random_stduniform(u)
      u = random_unif(one,rero)
      x = g*u**(1.0/alpha)
   else
      call random_stdgamma_alpha_ge_1(alpha,x)
   end if
end subroutine random_stdgamma

end module


      double precision function  fdisc(blockno,xc,yc)
      implicit none

      double precision xc,yc, phi, theta
      integer blockno

      double precision pi, pi2
      common /compi/ pi, pi2

      integer initchoice
      common /initchoice_comm/ initchoice

      integer*8 cont, get_context

      double precision xp, yp, zp

      double precision r, r0

      cont = get_context()

      call fclaw2d_map_c2m(cont,
     &         blockno,xc,yc,xp,yp,zp)

      call map2spherical(xp,yp,zp,theta,phi)

      fdisc = abs(theta-pi) - pi/6

c      r0 = 0.2
c      r = sqrt((xp-0.5)**2 + (yp-0.5)**2)
c      fdisc = r - r0

      end