        subroutine idz_estrank(eps,m,n,a,w,krank,ra)
c
c       estimates the numerical rank krank of an m x n matrix a
c       to precision eps. This routine applies n2 random vectors
c       to a, obtaining ra, where n2 is the greatest integer
c       less than or equal to m such that n2 is a positive integer
c       power of two. krank is typically about 8 higher than
c       the actual numerical rank.
c
c       input:
c       eps -- precision defining the numerical rank
c       m -- first dimension of a
c       n -- second dimension of a
c       a -- matrix whose rank is to be estimated
c       w -- initialization array that has been constructed
c            by routine idz_frmi
c
c       output:
c       krank -- estimate of the numerical rank of a;
c                this routine returns krank = 0 when the actual
c                numerical rank is nearly full (that is,
c                greater than n - 8 or n2 - 8)
c       ra -- product of an n2 x m random matrix and the m x n matrix
c             a, where n2 is the greatest integer less than or equal
c             to m such that n2 is a positive integer power of two;
c             ra doubles as a work array in the present routine, and so
c             must be at least n*n2+(n+1)*(n2+1) complex*16 elements
c             long
c
c       _N.B._: ra must be at least n*n2+(n2+1)*(n+1) complex*16
c               elements long for use in the present routine
c               (here, n2 is the greatest integer less than or equal
c               to m, such that n2 is a positive integer power of two).
c               This routine returns krank = 0 when the actual
c               numerical rank is nearly full.
c
        implicit none
        integer m,n,krank,n2,irat,lrat,iscal,lscal,ira,lra,lra2
        real*8 eps
        complex*16 a(m,n),ra(*),w(17*m+70)
c
c
c       Extract from the array w initialized by routine idz_frmi
c       the greatest integer less than or equal to m that is
c       a positive integer power of two.
c
        n2 = w(2)
c
c
c       Allocate memory in ra.
c
        lra = 0
c
        ira = lra+1
        lra2 = n2*n
        lra = lra+lra2
c
        irat = lra+1
        lrat = n*(n2+1)
        lra = lra+lrat
c
        iscal = lra+1
        lscal = n2+1
        lra = lra+lscal
c
        call idz_estrank0(eps,m,n,a,w,n2,krank,ra(ira),ra(irat),
     1                    ra(iscal))
c
c
        return
        end
c
c
c
c


      subroutine resid_alpha_hgd_adv(ctfmp,n_K,n_alpha,n_beta,np1_K,np1_
     &alpha,np1_beta,x,Nx,advc,ht,hx,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 advc
      real*8 ht
      real*8 hx
      real*8 myzero
      real*8 ctfmp(Nx)
      real*8 n_K(Nx)
      real*8 n_alpha(Nx)
      real*8 n_beta(Nx)
      real*8 np1_K(Nx)
      real*8 np1_alpha(Nx)
      real*8 np1_beta(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res
      real*8 qb
      res = 0.0D0
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = (-0.1D1 * n_alpha(i) + np1_alpha(i)) / ht - 0.250000000000000
     #0D0 * advc * np1_beta(i) * (-0.1D1 * np1_alpha(i - 1) + np1_alpha(
     #i + 1)) / hx / ctfmp(i) + np1_alpha(i) * np1_K(i) - 0.250000000000
     #0000D0 * advc * n_beta(i) * (-0.1D1 * n_alpha(i - 1) + n_alpha(i +
     # 1)) / hx / ctfmp(i) + n_alpha(i) * n_K(i)
      res = res + qb**2
      end do
      endif
      do i=2, Nx-1, 1
      qb = (-0.1D1 * n_alpha(i) + np1_alpha(i)) / ht - 0.250000000000000
     #0D0 * advc * np1_beta(i) * (-0.1D1 * np1_alpha(i - 1) + np1_alpha(
     #i + 1)) / hx / ctfmp(i) + np1_alpha(i) * np1_K(i) - 0.250000000000
     #0000D0 * advc * n_beta(i) * (-0.1D1 * n_alpha(i - 1) + n_alpha(i +
     # 1)) / hx / ctfmp(i) + n_alpha(i) * n_K(i)
      res = res + qb**2
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = np1_alpha(i) + myzero * x(i) - 0.1D1
      res = res + qb**2
      end do
      endif
      res = sqrt(res/(1*Nx))
      END


      FUNCTION rtbis(func,x1,x2,xacc)
      INTEGER JMAX
      REAL rtbis,x1,x2,xacc,func
      EXTERNAL func
      PARAMETER (JMAX=40)
      INTEGER j
      REAL dx,f,fmid,xmid
      fmid=func(x2)
      f=func(x1)
      if(f*fmid.ge.0.) pause 'root must be bracketed in rtbis'
      if(f.lt.0.)then
        rtbis=x1
        dx=x2-x1
      else
        rtbis=x2
        dx=x1-x2
      endif
      do 11 j=1,JMAX
        dx=dx*.5
        xmid=rtbis+dx
        fmid=func(xmid)
        if(fmid.le.0.)rtbis=xmid
        if(abs(dx).lt.xacc .or. fmid.eq.0.) return
11    continue
      pause 'too many bisections in rtbis'
      END

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


subroutine matmuls(x,v,p)
USE PARAM_MOD, only: NPar
implicit none
real, intent(in) :: v(NPar)
real, intent(in) :: x(NPar,NPar)
real, intent(out):: p(NPar)

integer :: n

n = size(v,1)
!    SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
call DSYMV('u',n,1d0,x,n,v,1,0d0,p,1)
end subroutine matmuls


FUNCTION intersect(begind_a,endd_a,begind_b,endd_b)
!
IMPLICIT NONE
!
! Function arguments
!
REAL :: begind_a,begind_b,endd_a,endd_b
REAL :: intersect
!
!     + + + purpose + + +
!     returns the intersection interval "distance" of two intervals
!     each defined by a greater and lesser value
!     obviously the units must be consistent.

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     begind_a - lesser value of interval a
!     endd_a   - greater value of interval a
!     begind_b - lesser value of interval b
!     endd_b   - greater value of interval b

!     + + + end specifications + + +

IF ((endd_a.LE.begind_b).OR.(begind_a.GE.endd_b)) THEN
  intersect = 0.0
          ! some part of interval b intersects interval a
ELSE IF ((begind_a.LE.begind_b).AND.(endd_a.GE.endd_b)) THEN
              ! interval a completely surrounds interval b
  intersect = endd_b - begind_b
ELSE IF (begind_a.LE.begind_b) THEN
              ! top part of interval b intersects farther end of interval a
  intersect = endd_a - begind_b
ELSE IF (endd_a.GE.endd_b) THEN
              ! farther end of interval b intersects nearer end of interval a
  intersect = endd_b - begind_a
ELSE
              ! interval b completely surrounds interval a
  intersect = endd_a - begind_a
END IF
!
END FUNCTION intersect

Project Documents/Source Code Original/Intersect.f90


submodule(forlab_math) forlab_math_signum

contains

    real(sp) elemental module function signum_rsp(x) result(sign)

        real(sp), intent(in) :: x

        if (x < 0.0_sp) then; sign = -1.0_sp
        elseif (x > 0.0_sp) then; sign = 1.0_sp
        else; sign = 0.0_sp
        end if

    end function signum_rsp
    real(dp) elemental module function signum_rdp(x) result(sign)

        real(dp), intent(in) :: x

        if (x < 0.0_dp) then; sign = -1.0_dp
        elseif (x > 0.0_dp) then; sign = 1.0_dp
        else; sign = 0.0_dp
        end if

    end function signum_rdp

    integer(int8) elemental module function signum_iint8(x) result(sign)

        integer(int8), intent(in) :: x

        if (x < 0_int8) then; sign = -1_int8
        elseif (x > 0_int8) then; sign = 1_int8
        else; sign = 0_int8
        end if

    end function signum_iint8
    integer(int16) elemental module function signum_iint16(x) result(sign)

        integer(int16), intent(in) :: x

        if (x < 0_int16) then; sign = -1_int16
        elseif (x > 0_int16) then; sign = 1_int16
        else; sign = 0_int16
        end if

    end function signum_iint16
    integer(int32) elemental module function signum_iint32(x) result(sign)

        integer(int32), intent(in) :: x

        if (x < 0_int32) then; sign = -1_int32
        elseif (x > 0_int32) then; sign = 1_int32
        else; sign = 0_int32
        end if

    end function signum_iint32
    integer(int64) elemental module function signum_iint64(x) result(sign)

        integer(int64), intent(in) :: x

        if (x < 0_int64) then; sign = -1_int64
        elseif (x > 0_int64) then; sign = 1_int64
        else; sign = 0_int64
        end if

    end function signum_iint64

    complex(sp) elemental module function signum_csp(x) result(sign)

        complex(sp), intent(in) :: x

        if (x == (0.0_sp, 0.0_sp)) then; sign = x
        else; sign = x/abs(x)
        end if

    end function signum_csp
    complex(dp) elemental module function signum_cdp(x) result(sign)

        complex(dp), intent(in) :: x

        if (x == (0.0_dp, 0.0_dp)) then; sign = x
        else; sign = x/abs(x)
        end if

    end function signum_cdp

end submodule forlab_math_signum


!*****************************************************************************************
!>
!  Orbital elements conversion tests.
!
!  This tests three types of orbital elements:
!
!  * classical
!  * modified equinoctial
!  * gooding

    program elements_test

    use fortran_astrodynamics_toolkit

    implicit none

    real(wp),dimension(3) :: r,v,r2,v2
    real(wp),dimension(6) :: rv,rv2,rv3,evec,gvec
    real(wp) :: mu
    real(wp) :: a,p,ecc,inc,raan,aop,tru
    real(wp) :: a2,p2,ecc2,inc2,raan2,aop2,tru2
    integer  :: i  !! counter

    mu = 3.9860043543609593E+05_wp ! for earth

    do i = 1, 8

        write(*,*) ''
        write(*,*) '---------------------------'

        select case (i)
        case (1)
            write(*,*) 'general elliptical:'
            a    = 8000.0_wp ! km
            ecc  = 0.1_wp
            inc  = 45.0_wp * deg2rad
            raan = 45.0_wp * deg2rad
            aop  = 45.0_wp * deg2rad
            tru  = 45.0_wp * deg2rad
            p = a * (one - ecc**2)
        case (2)
            write(*,*) 'circular:'
            a    = 8000.0_wp ! km
            ecc  = 0.00001_wp
            inc  = 45.0_wp * deg2rad
            raan = 45.0_wp * deg2rad
            aop  = 45.0_wp * deg2rad
            tru  = 45.0_wp * deg2rad
            p = a * (one - ecc**2)
        case (3)
            write(*,*) 'equatorial elliptical:'
            a    = 8000.0_wp ! km
            ecc  = 0.1_wp
            inc  = 0.00001_wp * deg2rad
            raan = 45.0_wp * deg2rad
            aop  = 45.0_wp * deg2rad
            tru  = 45.0_wp * deg2rad
            p = a * (one - ecc**2)
        case (4)
            write(*,*) 'circular and equatorial:'
            a    = 8000.0_wp ! km
            ecc  = 0.00001_wp
            inc  = 0.00001_wp * deg2rad
            raan = 45.0_wp * deg2rad
            aop  = 45.0_wp * deg2rad
            tru  = 45.0_wp * deg2rad
            p = a * (one - ecc**2)
        case (5)
            write(*,*) 'general hyperbolic:'
            a    = -80000.0_wp ! km
            ecc  = 1.1_wp
            inc  = 45.0_wp * deg2rad
            raan = 45.0_wp * deg2rad
            aop  = 45.0_wp * deg2rad
            tru  = 45.0_wp * deg2rad
            p = a * (one - ecc**2)
        case (6)
            write(*,*) 'equatorial hyperbolic:'
            a    = -80000.0_wp ! km
            ecc  = 1.1_wp
            inc  = 0.00001_wp * deg2rad
            raan = 45.0_wp * deg2rad
            aop  = 45.0_wp * deg2rad
            tru  = 45.0_wp * deg2rad
            p = a * (one - ecc**2)
        case (7)
            write(*,*) 'general parabolic:'
            p    = 80000.0_wp
            ecc  = 1.0_wp
            inc  = 45.0_wp * deg2rad
            raan = 45.0_wp * deg2rad
            aop  = 45.0_wp * deg2rad
            tru  = 45.0_wp * deg2rad
        case (8)
            write(*,*) 'equatorial parabolic:'
            p    = 80000.0_wp
            ecc  = 1.0_wp
            inc  = 0.00001_wp * deg2rad
            raan = 45.0_wp * deg2rad
            aop  = 45.0_wp * deg2rad
            tru  = 45.0_wp * deg2rad
        case default
            error stop 'invalid case number'
        end select

        write(*,*) '---------------------------'

        call orbital_elements_to_rv(mu, p, ecc, inc, raan, aop, tru, r, v)
        rv = [r,v]

        ! classical orbital elements:
        call rv_to_orbital_elements(mu, r, v, p2, ecc2, inc2, raan2, aop2, tru2)
        call orbital_elements_to_rv(mu, p2, ecc2, inc2, raan2, aop2, tru2, r2, v2)

        ! gooding elements:
        call pv3els(mu, rv, gvec)
        call els3pv(mu, gvec, rv2)

        ! modified equinoctial elements:
        call cartesian_to_equinoctial(mu, rv, evec)
        call equinoctial_to_cartesian(mu, evec, rv3)

        write(*,*) ''
        write(*,'(A22,*(E26.16,1X))') 'cartesian:', rv
        write(*,'(A22,*(E26.16,1X))') 'classical elements:', p, ecc, inc, raan, aop, tru
        write(*,'(A22,*(E26.16,1X))') 'gooding elements:', gvec
        write(*,'(A22,*(E26.16,1X))') 'equinoctial elements:', evec

        write(*,*) ''
        write(*,'(A22,*(E26.16,1X))') 'elements r diff:', r2 - r
        write(*,'(A22,*(E26.16,1X))') 'elements v diff:', v2 - v
        write(*,*) ''
        write(*,'(A22,*(E26.16,1X))') 'gooding r diff:', rv2(1:3) - rv(1:3)
        write(*,'(A22,*(E26.16,1X))') 'gooding v diff:', rv2(4:6) - rv(4:6)
        write(*,*) ''
        write(*,'(A22,*(E26.16,1X))') 'equinoctial r diff:', rv3(1:3) - rv(1:3)
        write(*,'(A22,*(E26.16,1X))') 'equinoctial v diff:', rv3(4:6) - rv(4:6)

    end do

    write(*,*) ''

!*****************************************************************************************
    end program elements_test
!*****************************************************************************************


program intrinsics_04
use iso_fortran_env, only: dp=>real64
real(dp) :: x
complex(dp) :: z

x = 1.5_dp
x = tan(x)
print *, x
if (abs(x - 14.101419947171721_dp) > 1e-10_dp) error stop

z = (1.5_dp, 3.5_dp)
z = tan(z)
print *, z
if (abs(real(z,dp) - 2.57834890405532317E-004_dp) > 1e-10_dp) error stop
!if (abs(aimag(z) - 1.0018071108086137_dp) > 1e-10_dp) error stop

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 CalcH20NablaShape(fXi, fEta, fZeta, faDS)
	Implicit None

	Real, Intent(IN) :: fXi, fEta, fZeta
	Real, Intent(OUT) :: faDS(60)
	Real fXiP, fEtaP, fZetaP, fXiM, fEtaM, fZetaM

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

! Calculation of natural coordinate derivatives of the shape functions
! Corresponding to fXi
	faDS(1) = 0.125D0 * fEtaM * fZetaM * (2D0 * fXi + fEta + fZeta + 1D0)
	faDS(2) = 0.125D0 * fEtaM * fZetaM * (2D0 * fXi - fEta - fZeta - 1D0)
	faDS(3) = 0.125D0 * fEtaP * fZetaM * (2D0 * fXi + fEta - fZeta - 1D0)
	faDS(4) = 0.125D0 * fEtaP * fZetaM * (2D0 * fXi - fEta + fZeta + 1D0)
	faDS(5) = 0.125D0 * fEtaM * fZetaP * (2D0 * fXi + fEta - fZeta + 1D0)
	faDS(6) = 0.125D0 * fEtaM * fZetaP * (2D0 * fXi - fEta + fZeta - 1D0)
	faDS(7) = 0.125D0 * fEtaP * fZetaP * (2D0 * fXi + fEta + fZeta - 1D0)
	faDS(8) = 0.125D0 * fEtaP * fZetaP * (2D0 * fXi - fEta - fZeta + 1D0)
	faDS(9) = -0.5D0 * fXi * fEtaM * fZetaM
	faDS(10) = 0.25D0 * fEtaM * fEtaP * fZetaM
	faDS(11) = -0.5D0 * fXi * fEtaP * fZetaM
	faDS(12) = -0.25D0 * fEtaM * fEtaP * fZetaM
	faDS(13) = -0.5D0 * fXi * fEtaM * fZetaP
	faDS(14) = 0.25D0 * fEtaM * fEtaP * fZetaP
	faDS(15) = -0.5D0 * fXi * fEtaP * fZetaP
	faDS(16) = -0.25D0 * fEtaM * fEtaP * fZetaP
	faDS(17) = -0.25D0 * fEtaM * fZetaP * fZetaM
	faDS(18) = 0.25D0 * fEtaM * fZetaP * fZetaM
	faDS(19) = 0.25D0 * fEtaP * fZetaP * fZetaM
	faDS(20) = -0.25D0 * fEtaP * fZetaP * fZetaM

! Corresponding to fEta
	faDS(21) = 0.125D0 * fXiM * fZetaM * (fXi + 2D0 * fEta + fZeta + 1D0)
	faDS(22) = 0.125D0 * fXiP * fZetaM * (-fXi + 2D0 * fEta + fZeta + 1D0)
	faDS(23) = 0.125D0 * fXiP * fZetaM * (fXi + 2D0 * fEta - fZeta - 1D0)
	faDS(24) = 0.125D0 * fXiM * fZetaM * (-fXi + 2D0 * fEta - fZeta - 1D0)
	faDS(25) = 0.125D0 * fXiM * fZetaP * (fXi + 2D0 * fEta - fZeta + 1D0)
	faDS(26) = 0.125D0 * fXiP * fZetaP * (-fXi + 2D0 * fEta - fZeta + 1D0)
	faDS(27) = 0.125D0 * fXiP * fZetaP * (fXi + 2D0 * fEta + fZeta - 1D0)
	faDS(28) = 0.125D0 * fXiM * fZetaP * (-fXi + 2D0 * fEta + fZeta - 1D0)
	faDS(29) = -0.25D0 * fXiP * fXiM * fZetaM
	faDS(30) = -0.5D0 * fXiP * fEta * fZetaM
	faDS(31) = 0.25D0 * fXiM * fXiP * fZetaM
	faDS(32) = -0.5D0 * fXiM * fEta * fZetaM
	faDS(33) = -0.25D0 * fXiP * fXiM * fZetaP
	faDS(34) = -0.5D0 * fEta * fXiP * fZetaP
	faDS(35) = 0.25D0 * fXiM * fXiP * fZetaP
	faDS(36) = -0.5D0 * fXiM * fEta * fZetaP
	faDS(37) = -0.25D0 * fXiM * fZetaP * fZetaM
	faDS(38) = -0.25D0 * fXiP * fZetaP * fZetaM
	faDS(39) = 0.25D0 * fXiP * fZetaP * fZetaM
	faDS(40) = 0.25D0 * fXiM * fZetaP * fZetaM

! Corresponding to fZeta
	faDS(41) = 0.125D0 * fXiM * fEtaM * (fXi + fEta + 2D0 * fZeta + 1D0)
	faDS(42) = 0.125D0 * fXiP * fEtaM * (-fXi + fEta + 2D0 * fZeta + 1D0)
	faDS(43) = 0.125D0 * fXiP * fEtaP * (-fXi - fEta + 2D0 * fZeta + 1D0)
	faDS(44) = 0.125D0 * fXiM * fEtaP * (fXi - fEta + 2D0 * fZeta + 1D0)
	faDS(45) = 0.125D0 * fXiM * fEtaM * (-fXi - fEta + 2D0 * fZeta - 1D0)
	faDS(46) = 0.125D0 * fXiP * fEtaM * (fXi - fEta + 2D0 * fZeta - 1D0)
	faDS(47) = 0.125D0 * fXiP * fEtaP * (fXi + fEta + 2D0 * fZeta - 1D0)
	faDS(48) = 0.125D0 * fXiM * fEtaP * (-fXi + fEta + 2D0 * fZeta - 1D0)
	faDS(49) = -0.25D0 * fXiP * fXiM * fEtaM
	faDS(50) = -0.25D0 * fXiP * fEtaP * fEtaM
	faDS(51) = -0.25D0 * fXiM * fXiP * fEtaP
	faDS(52) = -0.25D0 * fXiM * fEtaP * fEtaM
	faDS(53) = 0.25D0 * fXiP * fXiM * fEtaM
	faDS(54) = 0.25D0 * fXiP * fEtaP * fEtaM
	faDS(55) = 0.25D0 * fXiM * fXiP * fEtaP
	faDS(56) = 0.25D0 * fXiM * fEtaM * fEtaP
	faDS(57) = -0.5D0 * fXiM * fEtaM * fZeta
	faDS(58) = -0.5D0 * fXiP * fEtaM * fZeta
	faDS(59) = -0.5D0 * fXiP * fEtaP * fZeta
	faDS(60) = -0.5D0 * fXiM * fEtaP * fZeta
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 CalcH20Shape(fXi, fEta, fZeta, faS)
	Implicit None

	Real, Intent(IN) :: fXi, fEta, fZeta
	Real, Intent(OUT) :: faS(20)
	Real, Parameter :: fSqC125 = 0.5D0
	Real fXiP, fEtaP, fZetaP, fXiM, fEtaM, fZetaM, &
		fXi2, fEta2, fZeta2

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

	faS(1) = fXiM * fEtaM * fZetaM * (-fXi - fEta - fZeta - 2D0)
	faS(2) = fXiP * fEtaM * fZetaM * (fXi - fEta - fZeta - 2D0)
	faS(3) = fXiP * fEtaP * fZetaM * (fXi + fEta - fZeta - 2D0)
	faS(4) = fXiM * fEtaP * fZetaM * (-fXi + fEta - fZeta - 2D0)
	faS(5) = fXiM * fEtaM * fZetaP * (-fXi - fEta + fZeta - 2D0)
	faS(6) = fXiP * fEtaM * fZetaP * (fXi - fEta + fZeta - 2D0)
	faS(7) = fXiP * fEtaP * fZetaP * (fXi + fEta + fZeta - 2D0)
	faS(8) = fXiM * fEtaP * fZetaP * (-fXi + fEta + fZeta - 2D0)
	faS(9) = fXi2 * fEtaM * fZetaM
	faS(10) = fEta2 * fXiP * fZetaM
	faS(11) = fXi2 * fEtaP * fZetaM
	faS(12) = fEta2 * fXiM * fZetaM
	faS(13) = fXi2 * fEtaM * fZetaP
	faS(14) = fEta2 * fXiP * fZetaP
	faS(15) = fXi2 * fEtaP * fZetaP
	faS(16) = fEta2 * fXiM * fZetaP
	faS(17) = fZeta2 * fXiM * fEtaM
	faS(18) = fZeta2 * fXiP * fEtaM
	faS(19) = fZeta2 * fXiP * fEtaP
	faS(20) = fZeta2 * fXiM * fEtaP
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 CalcH20JDetJ(faXYZ, faDS, faJ, fDetJ)
	Implicit None
	Include 'hCommon.h'

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

! Main routine
	CalcH20JDetJ = 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) + faDS(9) * faXYZ(1, 9) + &
		faDS(10) * faXYZ(1, 10) + faDS(11) * faXYZ(1, 11) + &
		faDS(12) * faXYZ(1, 12) + faDS(13) * faXYZ(1, 13) + &
		faDS(14) * faXYZ(1, 14) + faDS(15) * faXYZ(1, 15) + &
		faDS(16) * faXYZ(1, 16) + faDS(17) * faXYZ(1, 17) + &
		faDS(18) * faXYZ(1, 18) + faDS(19) * faXYZ(1, 19) + &
		faDS(20) * faXYZ(1, 20)
	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) + faDS(9) * faXYZ(2, 9) + &
		faDS(10) * faXYZ(2, 10) + faDS(11) * faXYZ(2, 11) + &
		faDS(12) * faXYZ(2, 12) + faDS(13) * faXYZ(2, 13) + &
		faDS(14) * faXYZ(2, 14) + faDS(15) * faXYZ(2, 15) + &
		faDS(16) * faXYZ(2, 16) + faDS(17) * faXYZ(2, 17) + &
		faDS(18) * faXYZ(2, 18) + faDS(19) * faXYZ(2, 19) + &
		faDS(20) * faXYZ(2, 20)
	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) + faDS(9) * faXYZ(3, 9) + &
		faDS(10) * faXYZ(3, 10) + faDS(11) * faXYZ(3, 11) + &
		faDS(12) * faXYZ(3, 12) + faDS(13) * faXYZ(3, 13) + &
		faDS(14) * faXYZ(3, 14) + faDS(15) * faXYZ(3, 15) + &
		faDS(16) * faXYZ(3, 16) + faDS(17) * faXYZ(3, 17) + &
		faDS(18) * faXYZ(3, 18) + faDS(19) * faXYZ(3, 19) + &
		faDS(20) * faXYZ(3, 20)
	faJ(2, 1) = faDS(21) * faXYZ(1, 1) + &
		faDS(22) * faXYZ(1, 2) + faDS(23) * faXYZ(1, 3) + &
		faDS(24) * faXYZ(1, 4) + faDS(25) * faXYZ(1, 5) + &
		faDS(26) * faXYZ(1, 6) + faDS(27) * faXYZ(1, 7) + &
		faDS(28) * faXYZ(1, 8) + faDS(29) * faXYZ(1, 9) + &
		faDS(30) * faXYZ(1, 10) + faDS(31) * faXYZ(1, 11) + &
		faDS(32) * faXYZ(1, 12) + faDS(33) * faXYZ(1, 13) + &
		faDS(34) * faXYZ(1, 14) + faDS(35) * faXYZ(1, 15) + &
		faDS(36) * faXYZ(1, 16) + faDS(37) * faXYZ(1, 17) + &
		faDS(38) * faXYZ(1, 18) + faDS(39) * faXYZ(1, 19) + &
		faDS(40) * faXYZ(1, 20)
	faJ(2, 2) = faDS(21) * faXYZ(2, 1) + &
		faDS(22) * faXYZ(2, 2) + faDS(23) * faXYZ(2, 3) + &
		faDS(24) * faXYZ(2, 4) + faDS(25) * faXYZ(2, 5) + &
		faDS(26) * faXYZ(2, 6) + faDS(27) * faXYZ(2, 7) + &
		faDS(28) * faXYZ(2, 8) + faDS(29) * faXYZ(2, 9) + &
		faDS(30) * faXYZ(2, 10) + faDS(31) * faXYZ(2, 11) + &
		faDS(32) * faXYZ(2, 12) + faDS(33) * faXYZ(2, 13) + &
		faDS(34) * faXYZ(2, 14) + faDS(35) * faXYZ(2, 15) + &
		faDS(36) * faXYZ(2, 16) + faDS(37) * faXYZ(2, 17) + &
		faDS(38) * faXYZ(2, 18) + faDS(39) * faXYZ(2, 19) + &
		faDS(40) * faXYZ(2, 20)
	faJ(2, 3) = faDS(21) * faXYZ(3, 1) + &
		faDS(22) * faXYZ(3, 2) + faDS(23) * faXYZ(3, 3) + &
		faDS(24) * faXYZ(3, 4) + faDS(25) * faXYZ(3, 5) + &
		faDS(26) * faXYZ(3, 6) + faDS(27) * faXYZ(3, 7) + &
		faDS(28) * faXYZ(3, 8) + faDS(29) * faXYZ(3, 9) + &
		faDS(30) * faXYZ(3, 10) + faDS(31) * faXYZ(3, 11) + &
		faDS(32) * faXYZ(3, 12) + faDS(33) * faXYZ(3, 13) + &
		faDS(34) * faXYZ(3, 14) + faDS(35) * faXYZ(3, 15) + &
		faDS(36) * faXYZ(3, 16) + faDS(37) * faXYZ(3, 17) + &
		faDS(38) * faXYZ(3, 18) + faDS(39) * faXYZ(3, 19) + &
		faDS(40) * faXYZ(3, 20)
	faJ(3, 1) = faDS(41) * faXYZ(1, 1) + &
		faDS(42) * faXYZ(1, 2) + faDS(43) * faXYZ(1, 3) + &
		faDS(44) * faXYZ(1, 4) + faDS(45) * faXYZ(1, 5) + &
		faDS(46) * faXYZ(1, 6) + faDS(47) * faXYZ(1, 7) + &
		faDS(48) * faXYZ(1, 8) + faDS(49) * faXYZ(1, 9) + &
		faDS(50) * faXYZ(1, 10) + faDS(51) * faXYZ(1, 11) + &
		faDS(52) * faXYZ(1, 12) + faDS(53) * faXYZ(1, 13) + &
		faDS(54) * faXYZ(1, 14) + faDS(55) * faXYZ(1, 15) + &
		faDS(56) * faXYZ(1, 16) + faDS(57) * faXYZ(1, 17) + &
		faDS(58) * faXYZ(1, 18) + faDS(59) * faXYZ(1, 19) + &
		faDS(60) * faXYZ(1, 20)
	faJ(3, 2) = faDS(41) * faXYZ(2, 1) + &
		faDS(42) * faXYZ(2, 2) + faDS(43) * faXYZ(2, 3) + &
		faDS(44) * faXYZ(2, 4) + faDS(45) * faXYZ(2, 5) + &
		faDS(46) * faXYZ(2, 6) + faDS(47) * faXYZ(2, 7) + &
		faDS(48) * faXYZ(2, 8) + faDS(49) * faXYZ(2, 9) + &
		faDS(50) * faXYZ(2, 10) + faDS(51) * faXYZ(2, 11) + &
		faDS(52) * faXYZ(2, 12) + faDS(53) * faXYZ(2, 13) + &
		faDS(54) * faXYZ(2, 14) + faDS(55) * faXYZ(2, 15) + &
		faDS(56) * faXYZ(2, 16) + faDS(57) * faXYZ(2, 17) + &
		faDS(58) * faXYZ(2, 18) + faDS(59) * faXYZ(2, 19) + &
		faDS(60) * faXYZ(2, 20)
	faJ(3, 3) = faDS(41) * faXYZ(3, 1) + &
		faDS(42) * faXYZ(3, 2) + faDS(43) * faXYZ(3, 3) + &
		faDS(44) * faXYZ(3, 4) + faDS(45) * faXYZ(3, 5) + &
		faDS(46) * faXYZ(3, 6) + faDS(47) * faXYZ(3, 7) + &
		faDS(48) * faXYZ(3, 8) + faDS(49) * faXYZ(3, 9) + &
		faDS(50) * faXYZ(3, 10) + faDS(51) * faXYZ(3, 11) + &
		faDS(52) * faXYZ(3, 12) + faDS(53) * faXYZ(3, 13) + &
		faDS(54) * faXYZ(3, 14) + faDS(55) * faXYZ(3, 15) + &
		faDS(56) * faXYZ(3, 16) + faDS(57) * faXYZ(3, 17) + &
		faDS(58) * faXYZ(3, 18) + faDS(59) * faXYZ(3, 19) + &
		faDS(60) * faXYZ(3, 20)
	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 (H20)"
		Return
	EndIf
	CalcH20JDetJ = 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 CalcH20B(fDetJ, faJ, faDS, faB)
	Implicit None
	Include 'hCommon.h'

	Real, Intent(IN) :: fDetJ, faJ(3, 3), faDS(60)
	Real, Intent(OUT) :: faB(6, 60)
	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(21) + faJInv(1, 3) * faDS(41)
	faB(1, 2) = 0D0
	faB(1, 3) = 0D0
	faB(1, 4) = faJInv(1, 1) * faDS(2) + faJInv(1, 2) * faDS(22) + faJInv(1, 3) * faDS(42)
	faB(1, 5) = 0D0
	faB(1, 6) = 0D0
	faB(1, 7) = faJInv(1, 1) * faDS(3) + faJInv(1, 2) * faDS(23) + faJInv(1, 3) * faDS(43)
	faB(1, 8) = 0D0
	faB(1, 9) = 0D0
	faB(1, 10) = faJInv(1, 1) * faDS(4) + faJInv(1, 2) * faDS(24) + faJInv(1, 3) * faDS(44)
	faB(1, 11) = 0D0
	faB(1, 12) = 0D0
	faB(1, 13) = faJInv(1, 1) * faDS(5) + faJInv(1, 2) * faDS(25) + faJInv(1, 3) * faDS(45)
	faB(1, 14) = 0D0
	faB(1, 15) = 0D0
	faB(1, 16) = faJInv(1, 1) * faDS(6) + faJInv(1, 2) * faDS(26) + faJInv(1, 3) * faDS(46)
	faB(1, 17) = 0D0
	faB(1, 18) = 0D0
	faB(1, 19) = faJInv(1, 1) * faDS(7) + faJInv(1, 2) * faDS(27) + faJInv(1, 3) * faDS(47)
	faB(1, 20) = 0D0
	faB(1, 21) = 0D0
	faB(1, 22) = faJInv(1, 1) * faDS(8) + faJInv(1, 2) * faDS(28) + faJInv(1, 3) * faDS(48)
	faB(1, 23) = 0D0
	faB(1, 24) = 0D0
	faB(1, 25) = faJInv(1, 1) * faDS(9) + faJInv(1, 2) * faDS(29) + faJInv(1, 3) * faDS(49)
	faB(1, 26) = 0D0
	faB(1, 27) = 0D0
	faB(1, 28) = faJInv(1, 1) * faDS(10) + faJInv(1, 2) * faDS(30) + faJInv(1, 3) * faDS(50)
	faB(1, 29) = 0D0
	faB(1, 30) = 0D0
	faB(1, 31) = faJInv(1, 1) * faDS(11) + faJInv(1, 2) * faDS(31) + faJInv(1, 3) * faDS(51)
	faB(1, 32) = 0D0
	faB(1, 33) = 0D0
	faB(1, 34) = faJInv(1, 1) * faDS(12) + faJInv(1, 2) * faDS(32) + faJInv(1, 3) * faDS(52)
	faB(1, 35) = 0D0
	faB(1, 36) = 0D0
	faB(1, 37) = faJInv(1, 1) * faDS(13) + faJInv(1, 2) * faDS(33) + faJInv(1, 3) * faDS(53)
	faB(1, 38) = 0D0
	faB(1, 39) = 0D0
	faB(1, 40) = faJInv(1, 1) * faDS(14) + faJInv(1, 2) * faDS(34) + faJInv(1, 3) * faDS(54)
	faB(1, 41) = 0D0
	faB(1, 42) = 0D0
	faB(1, 43) = faJInv(1, 1) * faDS(15) + faJInv(1, 2) * faDS(35) + faJInv(1, 3) * faDS(55)
	faB(1, 44) = 0D0
	faB(1, 45) = 0D0
	faB(1, 46) = faJInv(1, 1) * faDS(16) + faJInv(1, 2) * faDS(36) + faJInv(1, 3) * faDS(56)
	faB(1, 47) = 0D0
	faB(1, 48) = 0D0
	faB(1, 49) = faJInv(1, 1) * faDS(17) + faJInv(1, 2) * faDS(37) + faJInv(1, 3) * faDS(57)
	faB(1, 50) = 0D0
	faB(1, 51) = 0D0
	faB(1, 52) = faJInv(1, 1) * faDS(18) + faJInv(1, 2) * faDS(38) + faJInv(1, 3) * faDS(58)
	faB(1, 53) = 0D0
	faB(1, 54) = 0D0
	faB(1, 55) = faJInv(1, 1) * faDS(19) + faJInv(1, 2) * faDS(39) + faJInv(1, 3) * faDS(59)
	faB(1, 56) = 0D0
	faB(1, 57) = 0D0
	faB(1, 58) = faJInv(1, 1) * faDS(20) + faJInv(1, 2) * faDS(40) + faJInv(1, 3) * faDS(60)
	faB(1, 59) = 0D0
	faB(1, 60) = 0D0
	faB(2, 1) = 0D0
	faB(2, 2) = faJInv(2, 1) * faDS(1) + faJInv(2, 2) * faDS(21) + faJInv(2, 3) * faDS(41)
	faB(2, 3) = 0D0
	faB(2, 4) = 0D0
	faB(2, 5) = faJInv(2, 1) * faDS(2) + faJInv(2, 2) * faDS(22) + faJInv(2, 3) * faDS(42)
	faB(2, 6) = 0D0
	faB(2, 7) = 0D0
	faB(2, 8) = faJInv(2, 1) * faDS(3) + faJInv(2, 2) * faDS(23) + faJInv(2, 3) * faDS(43)
	faB(2, 9) = 0D0
	faB(2, 10) = 0D0
	faB(2, 11) = faJInv(2, 1) * faDS(4) + faJInv(2, 2) * faDS(24) + faJInv(2, 3) * faDS(44)
	faB(2, 12) = 0D0
	faB(2, 13) = 0D0
	faB(2, 14) = faJInv(2, 1) * faDS(5) + faJInv(2, 2) * faDS(25) + faJInv(2, 3) * faDS(45)
	faB(2, 15) = 0D0
	faB(2, 16) = 0D0
	faB(2, 17) = faJInv(2, 1) * faDS(6) + faJInv(2, 2) * faDS(26) + faJInv(2, 3) * faDS(46)
	faB(2, 18) = 0D0
	faB(2, 19) = 0D0
	faB(2, 20) = faJInv(2, 1) * faDS(7) + faJInv(2, 2) * faDS(27) + faJInv(2, 3) * faDS(47)
	faB(2, 21) = 0D0
	faB(2, 22) = 0D0
	faB(2, 23) = faJInv(2, 1) * faDS(8) + faJInv(2, 2) * faDS(28) + faJInv(2, 3) * faDS(48)
	faB(2, 24) = 0D0
	faB(2, 25) = 0D0
	faB(2, 26) = faJInv(2, 1) * faDS(9) + faJInv(2, 2) * faDS(29) + faJInv(2, 3) * faDS(49)
	faB(2, 27) = 0D0
	faB(2, 28) = 0D0
	faB(2, 29) = faJInv(2, 1) * faDS(10) + faJInv(2, 2) * faDS(30) + faJInv(2, 3) * faDS(50)
	faB(2, 30) = 0D0
	faB(2, 31) = 0D0
	faB(2, 32) = faJInv(2, 1) * faDS(11) + faJInv(2, 2) * faDS(31) + faJInv(2, 3) * faDS(51)
	faB(2, 33) = 0D0
	faB(2, 34) = 0D0
	faB(2, 35) = faJInv(2, 1) * faDS(12) + faJInv(2, 2) * faDS(32) + faJInv(2, 3) * faDS(52)
	faB(2, 36) = 0D0
	faB(2, 37) = 0D0
	faB(2, 38) = faJInv(2, 1) * faDS(13) + faJInv(2, 2) * faDS(33) + faJInv(2, 3) * faDS(53)
	faB(2, 39) = 0D0
	faB(2, 40) = 0D0
	faB(2, 41) = faJInv(2, 1) * faDS(14) + faJInv(2, 2) * faDS(34) + faJInv(2, 3) * faDS(54)
	faB(2, 42) = 0D0
	faB(2, 43) = 0D0
	faB(2, 44) = faJInv(2, 1) * faDS(15) + faJInv(2, 2) * faDS(35) + faJInv(2, 3) * faDS(55)
	faB(2, 45) = 0D0
	faB(2, 46) = 0D0
	faB(2, 47) = faJInv(2, 1) * faDS(16) + faJInv(2, 2) * faDS(36) + faJInv(2, 3) * faDS(56)
	faB(2, 48) = 0D0
	faB(2, 49) = 0D0
	faB(2, 50) = faJInv(2, 1) * faDS(17) + faJInv(2, 2) * faDS(37) + faJInv(2, 3) * faDS(57)
	faB(2, 51) = 0D0
	faB(2, 52) = 0D0
	faB(2, 53) = faJInv(2, 1) * faDS(18) + faJInv(2, 2) * faDS(38) + faJInv(2, 3) * faDS(58)
	faB(2, 54) = 0D0
	faB(2, 55) = 0D0
	faB(2, 56) = faJInv(2, 1) * faDS(19) + faJInv(2, 2) * faDS(39) + faJInv(2, 3) * faDS(59)
	faB(2, 57) = 0D0
	faB(2, 58) = 0D0
	faB(2, 59) = faJInv(2, 1) * faDS(20) + faJInv(2, 2) * faDS(40) + faJInv(2, 3) * faDS(60)
	faB(2, 60) = 0D0
	faB(3, 1) = 0D0
	faB(3, 2) = 0D0
	faB(3, 3) = faJInv(3, 1) * faDS(1) + faJInv(3, 2) * faDS(21) + faJInv(3, 3) * faDS(41)
	faB(3, 4) = 0D0
	faB(3, 5) = 0D0
	faB(3, 6) = faJInv(3, 1) * faDS(2) + faJInv(3, 2) * faDS(22) + faJInv(3, 3) * faDS(42)
	faB(3, 7) = 0D0
	faB(3, 8) = 0D0
	faB(3, 9) = faJInv(3, 1) * faDS(3) + faJInv(3, 2) * faDS(23) + faJInv(3, 3) * faDS(43)
	faB(3, 10) = 0D0
	faB(3, 11) = 0D0
	faB(3, 12) = faJInv(3, 1) * faDS(4) + faJInv(3, 2) * faDS(24) + faJInv(3, 3) * faDS(44)
	faB(3, 13) = 0D0
	faB(3, 14) = 0D0
	faB(3, 15) = faJInv(3, 1) * faDS(5) + faJInv(3, 2) * faDS(25) + faJInv(3, 3) * faDS(45)
	faB(3, 16) = 0D0
	faB(3, 17) = 0D0
	faB(3, 18) = faJInv(3, 1) * faDS(6) + faJInv(3, 2) * faDS(26) + faJInv(3, 3) * faDS(46)
	faB(3, 19) = 0D0
	faB(3, 20) = 0D0
	faB(3, 21) = faJInv(3, 1) * faDS(7) + faJInv(3, 2) * faDS(27) + faJInv(3, 3) * faDS(47)
	faB(3, 22) = 0D0
	faB(3, 23) = 0D0
	faB(3, 24) = faJInv(3, 1) * faDS(8) + faJInv(3, 2) * faDS(28) + faJInv(3, 3) * faDS(48)
	faB(3, 25) = 0D0
	faB(3, 26) = 0D0
	faB(3, 27) = faJInv(3, 1) * faDS(9) + faJInv(3, 2) * faDS(29) + faJInv(3, 3) * faDS(49)
	faB(3, 28) = 0D0
	faB(3, 29) = 0D0
	faB(3, 30) = faJInv(3, 1) * faDS(10) + faJInv(3, 2) * faDS(30) + faJInv(3, 3) * faDS(50)
	faB(3, 31) = 0D0
	faB(3, 32) = 0D0
	faB(3, 33) = faJInv(3, 1) * faDS(11) + faJInv(3, 2) * faDS(31) + faJInv(3, 3) * faDS(51)
	faB(3, 34) = 0D0
	faB(3, 35) = 0D0
	faB(3, 36) = faJInv(3, 1) * faDS(12) + faJInv(3, 2) * faDS(32) + faJInv(3, 3) * faDS(52)
	faB(3, 37) = 0D0
	faB(3, 38) = 0D0
	faB(3, 39) = faJInv(3, 1) * faDS(13) + faJInv(3, 2) * faDS(33) + faJInv(3, 3) * faDS(53)
	faB(3, 40) = 0D0
	faB(3, 41) = 0D0
	faB(3, 42) = faJInv(3, 1) * faDS(14) + faJInv(3, 2) * faDS(34) + faJInv(3, 3) * faDS(54)
	faB(3, 43) = 0D0
	faB(3, 44) = 0D0
	faB(3, 45) = faJInv(3, 1) * faDS(15) + faJInv(3, 2) * faDS(35) + faJInv(3, 3) * faDS(55)
	faB(3, 46) = 0D0
	faB(3, 47) = 0D0
	faB(3, 48) = faJInv(3, 1) * faDS(16) + faJInv(3, 2) * faDS(36) + faJInv(3, 3) * faDS(56)
	faB(3, 49) = 0D0
	faB(3, 50) = 0D0
	faB(3, 51) = faJInv(3, 1) * faDS(17) + faJInv(3, 2) * faDS(37) + faJInv(3, 3) * faDS(57)
	faB(3, 52) = 0D0
	faB(3, 53) = 0D0
	faB(3, 54) = faJInv(3, 1) * faDS(18) + faJInv(3, 2) * faDS(38) + faJInv(3, 3) * faDS(58)
	faB(3, 55) = 0D0
	faB(3, 56) = 0D0
	faB(3, 57) = faJInv(3, 1) * faDS(19) + faJInv(3, 2) * faDS(39) + faJInv(3, 3) * faDS(59)
	faB(3, 58) = 0D0
	faB(3, 59) = 0D0
	faB(3, 60) = faJInv(3, 1) * faDS(20) + faJInv(3, 2) * faDS(40) + faJInv(3, 3) * faDS(60)
	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(4, 25) = faB(2, 26)
	faB(4, 26) = faB(1, 25)
	faB(4, 27) = 0D0
	faB(4, 28) = faB(2, 29)
	faB(4, 29) = faB(1, 28)
	faB(4, 30) = 0D0
	faB(4, 31) = faB(2, 32)
	faB(4, 32) = faB(1, 31)
	faB(4, 33) = 0D0
	faB(4, 34) = faB(2, 35)
	faB(4, 35) = faB(1, 34)
	faB(4, 36) = 0D0
	faB(4, 37) = faB(2, 38)
	faB(4, 38) = faB(1, 37)
	faB(4, 39) = 0D0
	faB(4, 40) = faB(2, 41)
	faB(4, 41) = faB(1, 40)
	faB(4, 42) = 0D0
	faB(4, 43) = faB(2, 44)
	faB(4, 44) = faB(1, 43)
	faB(4, 45) = 0D0
	faB(4, 46) = faB(2, 47)
	faB(4, 47) = faB(1, 46)
	faB(4, 48) = 0D0
	faB(4, 49) = faB(2, 50)
	faB(4, 50) = faB(1, 49)
	faB(4, 51) = 0D0
	faB(4, 52) = faB(2, 53)
	faB(4, 53) = faB(1, 52)
	faB(4, 54) = 0D0
	faB(4, 55) = faB(2, 56)
	faB(4, 56) = faB(1, 55)
	faB(4, 57) = 0D0
	faB(4, 58) = faB(2, 59)
	faB(4, 59) = faB(1, 58)
	faB(4, 60) = 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(5, 25) = 0D0
	faB(5, 26) = faB(3, 27)
	faB(5, 27) = faB(2, 26)
	faB(5, 28) = 0D0
	faB(5, 29) = faB(3, 30)
	faB(5, 30) = faB(2, 29)
	faB(5, 31) = 0D0
	faB(5, 32) = faB(3, 33)
	faB(5, 33) = faB(2, 32)
	faB(5, 34) = 0D0
	faB(5, 35) = faB(3, 36)
	faB(5, 36) = faB(2, 35)
	faB(5, 37) = 0D0
	faB(5, 38) = faB(3, 39)
	faB(5, 39) = faB(2, 38)
	faB(5, 40) = 0D0
	faB(5, 41) = faB(3, 42)
	faB(5, 42) = faB(2, 41)
	faB(5, 43) = 0D0
	faB(5, 44) = faB(3, 45)
	faB(5, 45) = faB(2, 44)
	faB(5, 46) = 0D0
	faB(5, 47) = faB(3, 48)
	faB(5, 48) = faB(2, 47)
	faB(5, 49) = 0D0
	faB(5, 50) = faB(3, 51)
	faB(5, 51) = faB(2, 50)
	faB(5, 52) = 0D0
	faB(5, 53) = faB(3, 54)
	faB(5, 54) = faB(2, 53)
	faB(5, 55) = 0D0
	faB(5, 56) = faB(3, 57)
	faB(5, 57) = faB(2, 56)
	faB(5, 58) = 0D0
	faB(5, 59) = faB(3, 60)
	faB(5, 60) = faB(2, 59)
	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)
	faB(6, 25) = faB(3, 27)
	faB(6, 26) = 0D0
	faB(6, 27) = faB(1, 25)
	faB(6, 28) = faB(3, 30)
	faB(6, 29) = 0D0
	faB(6, 30) = faB(1, 28)
	faB(6, 31) = faB(3, 33)
	faB(6, 32) = 0D0
	faB(6, 33) = faB(1, 31)
	faB(6, 34) = faB(3, 36)
	faB(6, 35) = 0D0
	faB(6, 36) = faB(1, 34)
	faB(6, 37) = faB(3, 39)
	faB(6, 38) = 0D0
	faB(6, 39) = faB(1, 37)
	faB(6, 40) = faB(3, 42)
	faB(6, 41) = 0D0
	faB(6, 42) = faB(1, 40)
	faB(6, 43) = faB(3, 45)
	faB(6, 44) = 0D0
	faB(6, 45) = faB(1, 43)
	faB(6, 46) = faB(3, 48)
	faB(6, 47) = 0D0
	faB(6, 48) = faB(1, 46)
	faB(6, 49) = faB(3, 51)
	faB(6, 50) = 0D0
	faB(6, 51) = faB(1, 49)
	faB(6, 52) = faB(3, 54)
	faB(6, 53) = 0D0
	faB(6, 54) = faB(1, 52)
	faB(6, 55) = faB(3, 57)
	faB(6, 56) = 0D0
	faB(6, 57) = faB(1, 55)
	faB(6, 58) = faB(3, 60)
	faB(6, 59) = 0D0
	faB(6, 60) = faB(1, 58)
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 CalcH20GaussMatrices(iInt, faXYZ, faWeight, faS, faDS, faJ, faDetJ, faB)
  !DEC$ ATTRIBUTES DLLEXPORT::CalcH20GaussMatrices
	Implicit None

	Integer, Intent(IN) :: iInt
	Real, Intent(IN) :: faXYZ(3, 20)
	Real, Intent(OUT) :: faDS(60, iInt ** 3), faS(20, iInt ** 3), &
		faB(6, 60, iInt ** 3), faDetJ(iInt ** 3), faJ(3, 3, iInt ** 3), &
		faWeight(iInt ** 3)
	Real fXi, fEta, fZeta
	Integer M, iX, iY, iZ, iErr, CalcH20JDetJ
	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 CalcH20NablaShape(fXi, fEta, fZeta, faDS(1, M))
				Call CalcH20Shape(fXi, fEta, fZeta, faS(1, M))
				iErr = CalcH20JDetJ(faXYZ, faDS(1, M), faJ(1, 1, M), faDetJ(M))
				Call CalcH20B(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 CalcH20K(iInt, faE, faB, faWeight, faK)
  !DEC$ ATTRIBUTES DLLEXPORT::CalcH20K
	Implicit None

	Integer, Intent(IN) :: iInt
	Real, Intent(IN) :: faWeight(iInt ** 3), faB(6, 60, iInt ** 3), faE(6, 6, iInt ** 3)
	Real, Intent(OUT) :: faK(1830)
	Real :: faEB(6), fStiff
	Integer :: I, J, K, M, KS, iX, iY, iZ

! Main routine
! Calculate stiffness matrix
	M = 0
	Do I = 1, 1830
		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, 60
					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, 60
						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 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 CalcH20Strains(iInt, faB, fau, faStrains)
  !DEC$ ATTRIBUTES DLLEXPORT::CalcH20Strains
	Implicit None

	Integer, Intent(IN) :: iInt
	Real, Intent(IN) :: faB(6, 60, iInt ** 3), fau(60)
	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 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:
! ---
! ******************************************
! AKYRO!!!! POULO H ROUTINA!!!
Subroutine CalcH20Stresses(iInt, faE, faStrains, faStresses)
	Implicit None
	Integer, Intent(IN) :: iInt
	Real, Intent(IN) :: faE(6, 6), faStrains(6, iInt ** 3)
	Real, Intent(OUT) :: faStresses(6, iInt ** 3)
	Integer :: M

! Main routine
	Do M = 1, iInt ** 3
		faStresses(:, M) = MatMul(faE, faStrains(:, M))
	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 CalcH20Forces(iInt, faB, faWeight, faStresses, faForces)
  !DEC$ ATTRIBUTES DLLEXPORT::CalcH20Forces
	Implicit None

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

! Main routine
! Calculate stiffness matrix
	M = 0
	Do iX = 1, 60
		faForces(iX) = 0.
	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

! ******************************************
! 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 CalcH20MConsistent(iInt, fDensity, faS, faWeight, faM)
	Implicit None

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

! Main routine
	M = 0
	Do I = 1, 1830
		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, 20
					Do J = I, 20
						KS = KS + 3
						faM(KS) = faM(KS) + faS(I, M) * faS(J, M) * fWeight
					EndDo

					Do K = 2, 3
!						iWidth = (21 - I) * 3 + 2 - K
						iWidth = 65 - K - 3 * I
						Do J = I, 20
							KS = KS + 3
							faM(KS) = faM(KS - iWidth)
						EndDo
						KS = KS - K + 1
					EndDo
				EndDo
			EndDo
		EndDo
	EndDo
!	Open(100, FILE = 'D:\GAnal\GAnalF\Mass3.txt', STATUS = 'NEW')
!	Do I = 1, 300
!		Write(100, 999) (I), faM(I)
!	EndDo
!	Close(100)
999 FORMAT (I5, F10.5)
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:
! ---
! ******************************************
Integer Function CalcH20MLumped(iInt, fDensity, faWeight, faM)
  !DEC$ ATTRIBUTES DLLEXPORT::CalcH20MLumped
	Implicit None

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

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

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

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

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

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

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

! 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
	fLocalForces(25) = 0D0
	fLocalForces(26) = 0D0
	fLocalForces(27) = 0D0
	fLocalForces(28) = 0D0
	fLocalForces(29) = 0D0
	fLocalForces(30) = 0D0
	fLocalForces(31) = 0D0
	fLocalForces(32) = 0D0
	fLocalForces(33) = 0D0
	fLocalForces(34) = 0D0
	fLocalForces(35) = 0D0
	fLocalForces(36) = 0D0
	fLocalForces(37) = 0D0
	fLocalForces(38) = 0D0
	fLocalForces(39) = 0D0
	fLocalForces(40) = 0D0
	fLocalForces(41) = 0D0
	fLocalForces(42) = 0D0
	fLocalForces(43) = 0D0
	fLocalForces(44) = 0D0
	fLocalForces(45) = 0D0
	fLocalForces(46) = 0D0
	fLocalForces(47) = 0D0
	fLocalForces(48) = 0D0
	fLocalForces(49) = 0D0
	fLocalForces(50) = 0D0
	fLocalForces(51) = 0D0
	fLocalForces(52) = 0D0
	fLocalForces(53) = 0D0
	fLocalForces(54) = 0D0
	fLocalForces(55) = 0D0
	fLocalForces(56) = 0D0
	fLocalForces(57) = 0D0
	fLocalForces(58) = 0D0
	fLocalForces(59) = 0D0
	fLocalForces(60) = 0D0

! Multiply SKYLINE Element M with vector pfAcc and store to fLocalForces
	iDataPos = 1
	Do I = 1, 60
		fLocalForces(I) = fLocalForces(I) + pfElementK(iDataPos) * pfU(I)
		iDataPos = iDataPos + 1
		Do J = I + 1, 60
			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)
	iTemp = piEqLM(25)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(25)
	iTemp = piEqLM(26)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(26)
	iTemp = piEqLM(27)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(27)
	iTemp = piEqLM(28)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(28)
	iTemp = piEqLM(29)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(29)
	iTemp = piEqLM(30)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(30)
	iTemp = piEqLM(31)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(31)
	iTemp = piEqLM(32)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(32)
	iTemp = piEqLM(33)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(33)
	iTemp = piEqLM(34)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(34)
	iTemp = piEqLM(35)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(35)
	iTemp = piEqLM(36)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(36)
	iTemp = piEqLM(37)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(37)
	iTemp = piEqLM(38)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(38)
	iTemp = piEqLM(39)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(39)
	iTemp = piEqLM(40)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(40)
	iTemp = piEqLM(41)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(41)
	iTemp = piEqLM(42)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(42)
	iTemp = piEqLM(43)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(43)
	iTemp = piEqLM(44)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(44)
	iTemp = piEqLM(45)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(45)
	iTemp = piEqLM(46)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(46)
	iTemp = piEqLM(47)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(47)
	iTemp = piEqLM(48)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(48)
	iTemp = piEqLM(49)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(49)
	iTemp = piEqLM(50)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(50)
	iTemp = piEqLM(51)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(51)
	iTemp = piEqLM(52)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(52)
	iTemp = piEqLM(53)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(53)
	iTemp = piEqLM(54)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(54)
	iTemp = piEqLM(55)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(55)
	iTemp = piEqLM(56)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(56)
	iTemp = piEqLM(57)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(57)
	iTemp = piEqLM(58)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(58)
	iTemp = piEqLM(59)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(59)
	iTemp = piEqLM(60)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(60)
End Subroutine

Subroutine CalcH20ForcesAcc(iInt, bIsLumped, fDensity, afAcc, afS, afWeights, afLocalForces)
	Implicit None
	Integer, Intent(IN) :: iInt
	Logical, Intent(IN) :: bIsLumped
	Real, Intent(IN) :: fDensity, afS(20, iInt ** 3), afAcc(3), afWeights(*)
	Real, Intent(OUT) :: afLocalForces(60)
	Integer :: I, J, iAccR, iDataPos, CalcH20MLumped, CalcH20MConsistent
	Real :: afM(1830)

! 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
	afLocalForces(25) = 0D0
	afLocalForces(26) = 0D0
	afLocalForces(27) = 0D0
	afLocalForces(28) = 0D0
	afLocalForces(29) = 0D0
	afLocalForces(30) = 0D0
	afLocalForces(31) = 0D0
	afLocalForces(32) = 0D0
	afLocalForces(33) = 0D0
	afLocalForces(34) = 0D0
	afLocalForces(35) = 0D0
	afLocalForces(36) = 0D0
	afLocalForces(37) = 0D0
	afLocalForces(38) = 0D0
	afLocalForces(39) = 0D0
	afLocalForces(40) = 0D0
	afLocalForces(41) = 0D0
	afLocalForces(42) = 0D0
	afLocalForces(43) = 0D0
	afLocalForces(44) = 0D0
	afLocalForces(45) = 0D0
	afLocalForces(46) = 0D0
	afLocalForces(47) = 0D0
	afLocalForces(48) = 0D0
	afLocalForces(49) = 0D0
	afLocalForces(50) = 0D0
	afLocalForces(51) = 0D0
	afLocalForces(52) = 0D0
	afLocalForces(53) = 0D0
	afLocalForces(54) = 0D0
	afLocalForces(55) = 0D0
	afLocalForces(56) = 0D0
	afLocalForces(57) = 0D0
	afLocalForces(58) = 0D0
	afLocalForces(59) = 0D0
	afLocalForces(60) = 0D0
	If (bIsLumped) Then
		I = CalcH20MLumped(iInt, fDensity, afWeights, afM)
	Else
		I = CalcH20MConsistent(iInt, fDensity, afS, afWeights, afM)
	End If

! Multiply SKYLINE Element M with vector pfAcc and store to fLocalForces
	iDataPos = 1
	Do I = 1, 60
		iAccR = mod(I - 1, 3) + 1
		afLocalForces(I) = afLocalForces(I) + afM(iDataPos) * afAcc(iAccR)
		iDataPos = iDataPos + 1
		Do J = I + 1, 60
			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 CalcH20ForcesFromAcc(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(60)

! 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
	fLocalForces(25) = 0D0
	fLocalForces(26) = 0D0
	fLocalForces(27) = 0D0
	fLocalForces(28) = 0D0
	fLocalForces(29) = 0D0
	fLocalForces(30) = 0D0
	fLocalForces(31) = 0D0
	fLocalForces(32) = 0D0
	fLocalForces(33) = 0D0
	fLocalForces(34) = 0D0
	fLocalForces(35) = 0D0
	fLocalForces(36) = 0D0
	fLocalForces(37) = 0D0
	fLocalForces(38) = 0D0
	fLocalForces(39) = 0D0
	fLocalForces(40) = 0D0
	fLocalForces(41) = 0D0
	fLocalForces(42) = 0D0
	fLocalForces(43) = 0D0
	fLocalForces(44) = 0D0
	fLocalForces(45) = 0D0
	fLocalForces(46) = 0D0
	fLocalForces(47) = 0D0
	fLocalForces(48) = 0D0
	fLocalForces(49) = 0D0
	fLocalForces(50) = 0D0
	fLocalForces(51) = 0D0
	fLocalForces(52) = 0D0
	fLocalForces(53) = 0D0
	fLocalForces(54) = 0D0
	fLocalForces(55) = 0D0
	fLocalForces(56) = 0D0
	fLocalForces(57) = 0D0
	fLocalForces(58) = 0D0
	fLocalForces(59) = 0D0
	fLocalForces(60) = 0D0

! Multiply SKYLINE Element M with vector pfAcc and store to fLocalForces
	iDataPos = 1
	Do I = 1, 60
		iAccR = mod(I - 1, 3) + 1
		fLocalForces(I) = fLocalForces(I) + pfElementM(iDataPos) * pfAcc(iAccR)
		iDataPos = iDataPos + 1
		Do J = I + 1, 60
			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)
	iTemp = piEqLM(25)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(25)
	iTemp = piEqLM(26)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(26)
	iTemp = piEqLM(27)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(27)
	iTemp = piEqLM(28)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(28)
	iTemp = piEqLM(29)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(29)
	iTemp = piEqLM(30)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(30)
	iTemp = piEqLM(31)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(31)
	iTemp = piEqLM(32)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(32)
	iTemp = piEqLM(33)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(33)
	iTemp = piEqLM(34)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(34)
	iTemp = piEqLM(35)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(35)
	iTemp = piEqLM(36)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(36)
	iTemp = piEqLM(37)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(37)
	iTemp = piEqLM(38)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(38)
	iTemp = piEqLM(39)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(39)
	iTemp = piEqLM(40)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(40)
	iTemp = piEqLM(41)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(41)
	iTemp = piEqLM(42)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(42)
	iTemp = piEqLM(43)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(43)
	iTemp = piEqLM(44)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(44)
	iTemp = piEqLM(45)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(45)
	iTemp = piEqLM(46)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(46)
	iTemp = piEqLM(47)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(47)
	iTemp = piEqLM(48)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(48)
	iTemp = piEqLM(49)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(49)
	iTemp = piEqLM(50)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(50)
	iTemp = piEqLM(51)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(51)
	iTemp = piEqLM(52)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(52)
	iTemp = piEqLM(53)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(53)
	iTemp = piEqLM(54)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(54)
	iTemp = piEqLM(55)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(55)
	iTemp = piEqLM(56)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(56)
	iTemp = piEqLM(57)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(57)
	iTemp = piEqLM(58)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(58)
	iTemp = piEqLM(59)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(59)
	iTemp = piEqLM(60)
	If (iTemp.GT.0) pfGlobalForces(iTemp) = pfGlobalForces(iTemp) + fLocalForces(60)
End Subroutine


      subroutine mapc2m_torus2(xc,yc,xp,yp,zp,alpha, beta)
      implicit none

      double precision xc,yc,xp,yp,zp
      double precision alpha, beta

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

      double precision r1, R, theta, phi

      call map_comp2torus(xc,yc,theta,phi)

      r1 = alpha*(1 + beta*sin(theta))
      R = 1 + r1*cos(phi)

      xp = R*cos(theta)
      yp = R*sin(theta)
      zp = r1*sin(phi)

      end


module pidef

    ! Value of pi
    real, parameter :: pi = 4.0*atan(1.0)
    real, parameter :: conrad = pi/180.0
    real, parameter :: condeg = 180.0/pi

end module pidef


 Program G1e13

!   Problema 13 Guia 1: Efectue con un programa en Fortran en simple precision los
!   siguientes calculos, matematicamente equivalentes,
!   a) 1 000 000 × 0.1
!   b) Sum de n=1, 1 000 000 de 0.1
!   c) Sum de m=1, 1 000 de Sum de n=1, 1 000
!       Explique las diferencias obtenidas entre resultados finales de a), b) y c) y muestre que el error relativo en b)
!       es del orden del 1%, pero es mucho menor en c). Resalte la conclusion de este ejercicio.

!   d) En los puntos b) y c), vaya guardando con un write (cada 1000 iteraciones en el caso b, y en todas
!        las iteraciones de la suma externa en c), los errores parciales en un archivo de datos. La primera
!        columna con los valores de los indices (multiplicados por 1000 para el caso c) de las sumas y segunda
!        columna con el error parcial, i.e., la diferencia entre el valor de la respectiva suma parcial y el valor
!        exacto (i ∗ 0:1). Grafique usando gnuplot, los errores parciales de b) y c) superpuestas, en funcion del
!        indice correspondiente, en un archivo\prob13.pdf" en color, con titulo de grafica\Problema 18, Guıa
!        1", con nombres adecuados en los ejes y con leyendas adecuadas. Los datos del b), graficarla con
!        puntos de tama~no 0.75 (el default es 1), y los de c) con linea de grosor 1.6 (el default es tambien 1).
!        Luego de ver como le queda la grafica en escala lineal, cambie el eje x, a escala logar´ıtmica. Segun su
!        criterio, en que escala se aprecia mejor el resultado del problema para su analisis? Puede al eje y darle
!        escala logaritmica? Pruebe que pasa si lo hace. Analice la conveniencia en general del uso de escalas
!        logaritmicas.
!        Finalmente deje el archivo grabado en escala lineal en y, y logaritmica en x, y diga el tama~no del
!        mismo tanto en bytes como Kbytes.
!
!                   Programa original escrito por Osvaldo Moreschi
!                   Programa modificado escrito por Edgardo Bonzi
!
!                             version 1.1
!                             08/04/2022
!
!                                                         Edgardo Bonzi
!                                                         edgardobonzi@gmail.com
!

   USE iso_fortran_env

   implicit none

   integer, parameter :: rs = real32
   integer, parameter :: rd = real64
   integer, parameter :: rl = real128

   integer, parameter :: wp = rl

   real(kind = wp) :: suma1 , suma2
   integer :: nmax , n, m, fu

  character(len=*), parameter :: PltFile = 'G1e13.plt'   ! Gnuplot file.

  nmax = 1000000

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

 ! a)
  suma1 = nmax * 0.1_wp
  write(*,*) ' 1000000 * 0.1_wp = ',suma1
 ! -----------------------------------

 ! b)
   open(newunit = fu, file = 'datossal/a_y_suma_b.dat ')
     write(fu,*) "# n, n * 0.1_wp , suma1 , ( suma1 - n * 0.1_wp)"

     suma1 = 0.0_wp
     do n = 1, nmax

        suma1 = suma1 + 0.1_wp
        if (mod(n, 1000) == 0) then
           write(fu, 500) n, n * 0.1_wp , suma1 , ( suma1 - n * 0.1_wp )
        end if

     end do
   close(fu)

  write (*,*) ' suma de 1 a 1000000 de 0.1_wp = ',suma1

 ! -----------------------------------
 ! c)

   suma1 = 0.0_wp
   suma2 = 0.0_wp

   do m = 1, 1000
     suma1 = suma1 + 0.1_wp
   end do

   open(newunit = fu, file = 'datossal/a_y_suma_c.dat ')
     write(fu,*) "# n, n * 100. _wp , suma2 , (suma2 - n * 100._wp)"

     do n = 1, 1000

       suma2 = suma2 + suma1

       write(fu, 500) n, n * 100._wp , suma2 , ( suma2 - n * 100._wp )
     end do

   close(fu)

   write(*,*) ' suma de 1 a 1000 de 1 a 1000 de 0.1_wp = ',suma2

  500 format(I8, 3(1X, ES20.13) )

      call system('gnuplot -p '//PltFile)

end program G1e13


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

SUBROUTINE splint(xa, ya, y2a, n, x, y)
    !
    ! Given the arrays ya(1:n) and xa(1:n) of length n, which tabulate a function
    ! and its independent variable (with the xa(i) in order, as in SPLINE),
    ! respectively, and given the array y2a(1:n), which is the output from SPLINE,
    ! and given a value of x, this routine returns a cubic-spline interpolated
    ! value y.  From "Numerical Recipes", Ch. 3.3, p. 110.
    IMPLICIT NONE
    ! Passed variables:
    INTEGER n
    REAL xa(n), ya(n), y2a(n), x, y
    ! Local variables:
    INTEGER k, klo, khi
    REAL a, b, h
    !
    klo = 1
    khi = n
    !
    ! Locate the interpolation point by means of bisection.
    ! This is optimal if sequential calls to this routine are at random values
    ! of x. If sequential calls are in order, and closely spaced, it would be
    ! better to store previous values of klo and khi and test if they remain
    ! appropriate on the next call.
    1    if (khi - klo.gt.1) then
        k = (khi + klo) / 2
        if (xa(k).gt.x) then
            khi = k
        else
            klo = k
        endif
        go to 1
    endif
    ! klo,khi now bracket x.
    h = xa(khi) - xa(klo)
    ! The xa's must be distinct:
    if (h.eq.0.e0) stop ' Bad xa input in splint'
    ! Evaluate now the cubic spline polynomial:
    a = (xa(khi) - x) / h
    b = (x - xa(klo)) / h
    y = a * ya(klo) + b * ya(khi) + &
            ((a * a * a - a) * y2a(klo) + (b * b * b - b) * y2a(khi)) * (h * h) / 6.e0
    !
    return
END


program tarefa6

    ! Definindo pi
    pi = 4*atan(1e0)

    ! Recebe o valor inteiro de N
    print *, 'Raízes da equação (Z - 2)**N = 3'
    print *, 'Digite o valor inteiro de N:'
    read (*,*) N

    ! loop k para solução geral z = |z|**(1/n) * ( cos( (theta+2*pi*k)/n ) + i*sin( (theta+2*pi*k)/n ) )
    ! forma polar do complexo z
    ! na equação theta = 0
    ! arg = 2*pi*k/n
    ! zmod = |z|
    do k = 1, N
        arg = 2e0*pi*k/N
        zmod = 3e0**(1e0/N)
        x = zmod*cos(arg) + 2e0
        yi = zmod*sin(arg)
        print '("Z"I0,": ",F8.5," ",SP,F8.5,"i")', k, cmplx(x, yi)
    end do

end program tarefa6


      subroutine AngWeight (k,a,b,ai,xmyi)
c******************************************************************************
c     For integration between the upper bound B and the lower bound A, this
c     Routine gives Gaussian weights and integration points.

c     Source for data: Lowan, Davids, Levenson,  Bull Amer Math Soc  48 page 739  (1942)
c     Source for original code: Olof Morell, Uppsala (03-1988)

c     ai/wtmu = weights, xmyi/mu = integration points

c     Until code below is altered, AngWeight works only with odd numbers of rays.
c*****************************************************************************

      implicit real*8 (a-h,o-z)
      real*8 ai(5), xmyi(5), ap(29), xmyp(29)
      integer kud, ioev, ined, indov(9)
      data ap/1.0,0.55555555555555,.88888888888888,.347854845137,
     &        0.65214515486254,0.23692688505618,0.47862867049936,
     &        0.56888888888888,0.17132449237917,0.36076157304813,
     &        0.46791393457269,0.12948496616887,0.27970539148927,
     &        0.38183005050511,0.41795918367346,0.10122853629037,
     &        0.22238103445337,0.31370664587788,0.36268378337836,
     &        0.08127438836157,0.18064816069485,0.26061069640293,
     &        0.31234707704000,0.33023935500126,0.06667134430868,
     &        0.14945134915058,0.21908636251598,0.26926671930999,
     &        0.29552422471475/
      data xmyp/
     &     0.57735026918962,.77459666924148,.0,0.86113631159405,
     &     0.33998104358485,.90617984593866,.53846931010568,.0,
     &     0.93246951420315,.66120938646626,.23861918608319,
     &     0.94910791234275,.74153118559939,.40584515137739,.0,
     &     0.96028985649753,.79666647741362,.52553240991632,
     &     0.18343464249565,.96816023950762,.83603110732663,
     &     0.61337143270059,.32425342340380,.0,0.97390652851717,
     &     0.86506336668898,.67940956829902,.43339539412924,
     &     0.14887433898163/
      data indov/1,3,5,8,11,15,19,24,29/

      if (k .eq. 1) then
         xmyi(1) = (b + a)/2.
         ai(1) = b - a
         return
      endif

      kud = 0
      flk = dfloat(k)/2.
      k2 = k/2
      fk = dfloat(k2)
      if (dabs(flk-fk) .ge. -1.0d-7) then
         k2 = k2 + 1
         kud = 1
      endif
      ioev = indov(k-1)
      ined = ioev - k2
      do i=1,k2
         ip = ined + i
         xmyi(i) = (-xmyp(ip)*(b-a) + (b+a))/2.
         ai(i) = (b-a)*ap(ip)/2.
      enddo
      k2 = k2 + 1
      do i=k2,k
        ip = ioev + k2 - i
        if (kud .gt. 0) ip = ip - 1
        xmyi(i)= (xmyp(ip)*(b-a) + (b+a))/2.
        ai(i) = (b-a)*ap(ip)/2.
      enddo

      return
      end


!--------------------------------------------------------------
! A simple A-grid shallow water model for a meridional channel
! John D. McCalpin, mccalpin@perelandra.cms.udel.edu
! Thu Jul  1 23:07:57 EDT 1993
!--------------------------------------------------------------
program sw
implicit double precision (a-h,o-z)

double precision,parameter::            Pi = 3.1415926535d0
integer,parameter::             M=8000,N=120                     ! RJA - M and N appear to be problem sizes. Originally 500 and 60.
integer,parameter::             NSTEPS=6480,IPLOT=4320           ! RJA - NSTEPS is iteration count. Originally 6480.
integer,parameter::             JWID=10
logical,parameter::             NSIGHT=.false.
logical,parameter::             CONTOOL=.false.
logical,parameter::             F_PLANE=.false.
logical,parameter::             B_PLANE=.true.
logical,parameter::             BORDERS=.true.
logical,parameter::             SMOOTH=.true.
integer                         new,mid,old
double precision,dimension(M,N,3)::             u,v,h
double precision,dimension(M,N)::               f,dudx,dvdy,dhdx,dhdy
double precision,dimension(M)::         Kelvin, tmp

! initialize arrays to zero
u = 0
v = 0
h = 0

! other initialization
dx = 10000.d0   ; dy = 60000.d0 ; dt = 2400.d0
f0 = 8.d-5      ; beta = 2.d-11 ; g = 0.02d0    ; Href = 288.0d0
c = sqrt(g*Href)
Rd = c/f0
a = sqrt(Href/g)

! now define meridional dependence of Coriolis force

if (F_PLANE) then
    f = f0                              ! constant f=f0
else if (B_PLANE) then
    if (BORDERS) then
        dely = (N-2*JWID)*dy
        f(1:M,1:JWID) = f0-beta*0.5d0*dely
        f(1:M,N-JWID:N) = f0 + beta*0.5d0*dely
        do j=JWID+1,N-(JWID+1)          ! linear except near the boundaries
            y = (j-(N/2))*dy
            f(1:M,j) = f0 + beta*y
        end do
        if (SMOOTH) then                ! beta goes smoothly to zero at bdrys
            do j=JWID,1,-1
                f(1:M,j) = f(1:M,j+1)-beta*(real(j-1)/real(JWID))*dy
            end do
            do j=N-JWID,N
                f(1:M,j) = f(1:M,j-1)+beta*(real(N-j)/real(JWID))*dy
            end do
        end if
    else
        do j=1,N                        ! b-plane all the way to boundary
            y = (j-(N/2))*dy
            f(1:M,j) = f0 + beta*y
        end do
    end if
end if

! define Kelvin wave structure in x to be balanced at the southern boundary
scale = (c/f(M,1))
do i=1,M
    Kelvin(i) = exp((i-M)*dx/scale)
end do

! run parameters
period = 0.6666666666d0*360.d0*86400.d0
omega = 2*Pi/period
v0 = 0.1d0

! Document parameters in output file

print *,'--------------------------------------------------------------------'
print *,'INFORMATION ABOUT DISCRETIZATION'
print *,'--------------------------------'
print *,'Grid size is ',M,N
print *,'dx, dy, dt = ',dx,dy,dt
print *,'domain size is ',dx*M/1000,dy*N/1000,' (km)'
print *
print *,'PHYSICAL PARAMETERS'
print *,'-------------------'
print *,'g, Href, c = ',g,Href,c
print *,'f0, fmin, fmax = ',f0,f(M,1),f(M,N)
print *,'beta = ',beta
Rd_max = c/f(M,1)       ; Rd_min = c/f(M,N)
print *,'Rd (mean, max, min) = ', c/f0/1000.,Rd_max/1000.,Rd_min/1000.,' (km)'
print *,'cfl(x,y) = ',c*dt/dx,c*dt/dy
print *
print *,'KELVIN WAVE PARAMETERS'
print *,'----------------------'
print *,'Incoming Kelvin wave amplitude: v0 = ',v0
print *,'Period = ',period,' (seconds) = ',period/(360.*86400.),' (years)'
print *,'f-plane Kelvin wave y scale = ',c/omega,' (m)'
print *,'                            = ',(c/omega)/dy,' (grid intervals)'
print *
print *,'OTHER INFORMATION'
print *,'-----------------'
print *,'Run length: NSTEPS = ',NSTEPS,' = ',NSTEPS*dt/period,' periods'
print *,'Plots every IPLOT steps = ',IPLOT,' = ',IPLOT*dt/period,' periods'
c_Rossby_max = beta*Rd_max**2
print *,'Maximum Rossby wave phase speed = ',c_Rossby_max
print *,'Distance travelled during simulation = ',c_Rossby_max*dt*NSTEPS,' (m)'
print *,'                                     = ',c_Rossby_max*dt*NSTEPS/dx, &
                                                ' (grid intervals)'
if (c_Rossby_max*dt*NSTEPS/(dx*M).gt.1.5d0) then
    print *,'*************************************************************'
    print *,'Rossby waves will travel ',c_Rossby_max*dt*NSTEPS/(dx*M), &
        ' basin widths in the simulation'
    print *,'You probably do not want this -- bailing out....'
    print *,'*************************************************************'
    stop
end if
print *,'--------------------------------------------------------------------'
print *,'Coriolis parameter = '
print *,'    j,f(j)       = ',1,f(M,1)
do j=2,N
    print *,'    j,f(j),df/dy = ',j,f(M,j),f(M,j)-f(M,j-1)
end do
print *,'--------------------------------------------------------------------'

! open and initialize output data file
if (NSIGHT) then
    open (unit=3,file='nsight.sw',status='unknown')
    write (3,*) 'scalars 1'
    write (3,*) "scalar 1 name 'Height'"
    write (3,*) 'vectors 1'
    write (3,*) "vector 1 name 'Velocity' size magnitude dimension 2"
    write (3,*) 'frames ',NSTEPS/IPLOT,' time'
else if (CONTOOL) then
    open (unit=3,file='contool.sw',status='unknown')
end if

old = 1
mid = 2
new = 3

!---------------------- BEGIN TIME MARCHING LOOP -------------------------
do istep=1,NSTEPS
    time = istep*dt

    ! ------ interior calculations ------ !

    dudx = ddx(u(:,:,mid))
    dvdy = ddy(v(:,:,mid))
    dhdx = ddx(h(:,:,mid))
    dhdy = ddy(h(:,:,mid))

    u(2:M-1,1:N,new) = u(2:M-1,1:N,old) &               ! interior u points
        +2.d0*dt*f(2:M-1,1:N)*v(2:M-1,1:N,mid) &
        -2.d0*dt/(2.d0*dx)*g*dhdx(2:M-1,1:N)

    v(1:M,2:N-1,new) = v(1:M,2:N-1,old) &               ! interior v points
        -2.d0*dt*f(1:M,2:N-1)*u(1:M,2:N-1,mid) &
        -2.d0*dt/(2.d0*dy)*g*dhdy(1:M,2:N-1)

    h(1:M,2:N-1,new) = h(1:M,2:N-1,old) &               ! interior h points
        -2.d0*dt/(2.d0*dx)*Href*dudx(1:M,2:N-1) &
        -2.d0*dt/(2.d0*dy)*Href*dvdy(1:M,2:N-1)

    ! ------ boundary calculations ------ !

    ! calculate outgoing characteristic variable at southern boundary
    tmp(1:M) = (1.d0/(c*dt+dx))*( (Href*dt-a*dx)*v(1:M,1,old) &
                               +(dx-c*dt)*h(1:M,1,old) &
                               -2*Href*dt*v(1:M,2,mid) &
                               +2*c*dt*h(1:M,2,mid) )

    ! add in incoming Kelvin wave characteristic variable
    v(1:M,1,new) = v0*sin(omega*time)*Kelvin(1:M) &       ! southern v points
                    -(0.5d0/a)*tmp(1:M)
    h(1:M,1,new) = a*v0*sin(omega*time)*Kelvin(1:M) & ! southern h points
                    +0.5d0*tmp(1:M)

    ! calculate outgoing characteristic variable at northern boundary
    tmp(1:M) = (1.d0/(c*dt+dx))*( (-Href*dt+a*dx)*v(1:M,N,old) &
                               +(dx-c*dt)*h(1:M,N,old) &
                               +2*Href*dt*v(1:M,N-1,mid) &
                               +2*c*dt*h(1:M,N-1,mid) )
    v(1:M,N,new) = (0.5d0/a)*tmp(1:M)                   ! separate v
    h(1:M,N,new) = 0.5d0*tmp(1:M)                               ! separate h

    iswap = old
    old = mid
    mid = new
    new = iswap

    if (mod(istep,IPLOT)==0) then
        call list ('h',time*omega/(2*Pi),h(1,1,mid),M,N)
!        call list ('u',time*omega/(2*Pi),u(1,1,mid),M,N)
!        call list ('v',time*omega/(2*Pi),v(1,1,mid),M,N)
        if (NSIGHT) then
            write (3,*) 'frame ',istep/IPLOT,' value ',time*omega/(2*3.14159)
            write (3,*) 'surfaces 1'
            write (3,*) 'surface 1 curves ',N,' nodes ',M, &
                    ' scalars 1 vectors 1 planar'
            write (3,*) "scalar 1 name 'Height'"
            write (3,*) "vector 1 name 'Velocity'"
            do j=1,N
                write (3,*) 'curve ',j
                do i=1,M
                    write (3,'(3(f9.0,1x),f8.3,1x,2(f8.4,1x))',err=9999) &
                            real(i-M)*dx,real(j)*dy,0.0, &
                            h(i,j,mid),u(i,j,mid),v(i,j,mid)
                end do
            end do
        else if (CONTOOL) then
            write (3,*) 'KELVIN-ROSSBY PROBLEM'
            write (3,*) M,N
            write (3,*) 1,1
            write (3,*) M,N
            write (3,*) -21.0,+21.0,2.0
            write (3,*) 0,-1,-31
            write (3,*) '(6(1pe12.5))'
            write (3,'(6(1pe12.5))') ((h(i,j,mid),i=1,M),j=1,N)
        end if
    end if

end do
!---------------------- END TIME MARCHING LOOP ---------------------------

if (NSIGHT .or. CONTOOL) then
    close(unit=3)
end if
stop

9999 print *,   'FORMAT ERROR at: ',i,j
print *,real(i),real(j),0.0,h(i,j,mid), &
                0.5*(u(i,j,mid)+u(i-1,j,mid)), &
                0.5*(v(i,j,mid)+v(i,j-1,mid))

!------------------------------------------------------------
contains
!------------------------------------------------------------
    function ddx(array)
    implicit double precision (a-h,o-z)
    double precision::          array(:,:)
    double precision::          ddx(size(array,dim=1),size(array,dim=2))

    I = size(array,dim=1)
    J = size(array,dim=2)

    ddx(2:I-1,1:J) = array(3:I,1:J)-array(1:I-2,1:J)    ! interior points

    ddx(1,1:J) = 2*(array(2,1:J)-array(  1,1:J))
    ddx(I,1:J) = 2*(array(I,1:J)-array(I-1,1:J))

    end function ddx

    function ddy(array)
    implicit double precision (a-h,o-z)
    double precision::          array(:,:)
    double precision::          ddy(size(array,dim=1),size(array,dim=2))

    I = size(array,dim=1)
    J = size(array,dim=2)

    ddy(1:I,2:J-1) = array(1:I,3:J)-array(1:I,1:J-2)    ! interior points

    ddy(1:I,1) = 2*(array(1:I,2)-array(1:I,  1))
    ddy(1:I,J) = 2*(array(1:I,J)-array(1:I,J-1))

    end function ddy
!------------------------------------------------------------
end program sw

!------------------------------------------------------------
subroutine list (label,time,array,M,N)
implicit double precision (a-h,o-z)
character*(*)::         label
integer::               M,N
double precision::                      time,array(M,N)

write (*,'(a,a,f8.4,a,1pe12.5)') label,' field at time = ',time, &
                                ' maxval = ',maxval(array)
do j=N,1,-2
    write (*,'(1x,25f5.1)') (array(i,j),i=M-14,M)
end do
end subroutine list
!------------------------------------------------------------
!------------------------------------------------------------
!interface
!    function ddx (array)
!       double precision::              array(:,:)
!       double precision::              ddx(size(array,dim=1),size(array,dim=2))
!    end function ddx
!    function ddy (array)
!       double precision::              array(:,:)
!       double precision::              ddy(size(array,dim=1),size(array,dim=2))
!    end function ddy
!end interface
!------------------------------------------------------------


! Modified to add module parameter tol

module newton

    ! module parameters:
    implicit none
    integer, parameter :: maxiter = 40
    real(kind=8), parameter :: tol = 1.d-14
    save

contains

subroutine solve(f, fp, x0, x, iters, debug)

    ! Estimate the zero of f(x) using Newton's method.
    ! Input:
    !   f:  the function to find a root of
    !   fp: function returning the derivative f'
    !   x0: the initial guess
    !   debug: logical, prints iterations if debug=.true.
    ! Returns:
    !   the estimate x satisfying f(x)=0 (assumes Newton converged!)
    !   the number of iterations iters

    implicit none
    real(kind=8), intent(in) :: x0
    real(kind=8), external :: f, fp
    logical, intent(in) :: debug
    real(kind=8), intent(out) :: x
    integer, intent(out) :: iters

    ! Declare any local variables:
    real(kind=8) :: deltax, fx, fxprime
    integer :: k

    ! initial guess
    x = x0

    if (debug) then
        print 11, x
 11     format('Initial guess: x = ', es22.15)
	    endif

    ! Newton iteration to find a zero of f(x)

    do k=1,maxiter

        ! evaluate function and its derivative:
        fx = f(x)
        fxprime = fp(x)

        if (abs(fx) < tol) then
            exit
            endif

        ! compute Newton increment x:
        deltax = fx/fxprime

        ! update x:
        x = x - deltax

        if (debug) then
            print 12, k,x
 12         format('After', i3, ' iterations, x = ', es22.15)
	        endif

        enddo

    if (k > maxiter) then
        ! might not have converged

        fx = f(x)
        if (abs(fx) > tol) then
            print *, '*** Warning: has not yet converged'
            endif
        endif

    ! number of iterations taken:
    iters = k-1

end subroutine solve

end module newton


program Pancake_Demo
  implicit none

  integer :: list(8) = (/ 1, 4, 7, 2, 5, 8, 3, 6 /)

  call Pancake_sort(list)

contains

subroutine Pancake_sort(a)

  integer, intent(in out) :: a(:)
  integer :: i, maxpos

  write(*,*) a
  do i = size(a), 2, -1

! Find position of max number between index 1 and i
    maxpos = maxloc(a(1:i), 1)

! is it in the correct position already?
    if (maxpos == i) cycle

! is it at the beginning of the array? If not flip array section so it is
    if (maxpos /= 1) then
      a(1:maxpos) = a(maxpos:1:-1)
      write(*,*) a
    end if

! Flip array section to get max number to correct position
    a(1:i) = a(i:1:-1)
    write(*,*) a
  end do

end subroutine

end program Pancake_Demo