	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This program use a monte carlo method to calculate pi
	!
	! .. Parameters ..
	!  npts				= total number of Monte Carlo points
	!  xmin				= lower bound for integration region
	!  xmax             = upper bound for integration region
	! .. Scalars ..
	!  i                = loop counter
	!  f				= average value from summation
	!  sum              = total sum
	!  randnum          = random number generated from (0,1) uniform
	!                     distribution
	!  x                = current Monte Carlo location
	! .. Arrays ..
	!
	! .. Vectors ..
	!
	! REFERENCES
	! http://chpc.wustl.edu/mpi-fortran.html
	! Gropp, Lusk and Skjellum, "Using MPI" MIT press (1999)
	!
	! ACKNOWLEDGEMENTS
	! The program below was modified from one available at the internet
	! address in the references. This internet address was last checked
	! on 30 March 2012
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	!
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! None
 	PROGRAM monte_carlo
    IMPLICIT NONE

    INTEGER(kind=8), PARAMETER 	    :: npts = 1e10
    REAL(kind=8), PARAMETER 		:: xmin=0.0d0,xmax=1.0d0
    INTEGER(kind=8) 				:: i
    REAL(kind=8) 					:: f,sum, randnum,x

    DO i=1,npts
      CALL random_number(randnum)
      x = (xmax-xmin)*randnum + xmin
      sum = sum + 4.0d0/(1.0d0 + x**2)
    END DO
    f = sum/npts
    PRINT*,'PI calculated with ',npts,' points = ',f

    STOP
    END


/* Examples for testing */

 "hello";

timesfloat 2.0 3.14159;

unit;

let x=true in x;

lambda f:Rec X.A->A. lambda x:A. f x;

lambda x:Bool. x;
(lambda x:Bool->Bool. if x false then true else false)
  (lambda x:Bool. if x then false else true);

lambda x:Nat. succ x;
(lambda x:Nat. succ (succ x)) (succ 0);

{x=true, y=false};
{x=true, y=false}.x;
{true, false};
{true, false}.1;

lambda x:<a:Bool,b:Bool>. x;

Counter = Rec P. {get:Nat, inc:Unit->P};

p =
let create =
  fix
    (lambda cr: {x:Nat}->Counter.
      lambda s: {x:Nat}.
        {get = s.x,
         inc = lambda _:Unit. cr {x=succ(s.x)}})
in
  create {x=0};

p1 = p.inc unit;
p1.get;

get = lambda p:Counter. p.get;
inc = lambda p:Counter. p.inc;

Hungry = Rec A. Nat -> A;

f0 =
fix
  (lambda f: Nat->Hungry.
   lambda n:Nat.
     f);

f1 = f0 0;
f2 = f1 2;

T = Nat;

fix_T =
lambda f:T->T.
  (lambda x:(Rec A.A->T). f (x x))
  (lambda x:(Rec A.A->T). f (x x));

D = Rec X. X->X;

fix_D =
lambda f:D->D.
  (lambda x:(Rec A.A->D). f (x x))
  (lambda x:(Rec A.A->D). f (x x));

diverge_D = lambda _:Unit. fix_D (lambda x:D. x);

lam = lambda f:D->D. f;
ap = lambda f:D. lambda a:D. f a;

myfix = lam (lambda f:D.
             ap (lam (lambda x:D. ap f (ap x x)))
                (lam (lambda x:D. ap f (ap x x))));

NatList = Rec X. <nil:Unit, cons:{Nat,X}>;

nil = <nil=unit> as NatList;

cons = lambda n:Nat. lambda l:NatList. <cons={n,l}> as NatList;

isnil = lambda l:NatList.
case l of
<nil=u> ==> true
| <cons=p> ==> false;

hd = lambda l:NatList.
case l of
<nil=u> ==> 0
| <cons=p> ==> p.1;

tl = lambda l:NatList.
case l of
<nil=u> ==> l
| <cons=p> ==> p.2;

plus = fix (lambda p:Nat->Nat->Nat.
lambda m:Nat. lambda n:Nat.
if iszero m then n else succ (p (pred m) n));

sumlist = fix (lambda s:NatList->Nat. lambda l:NatList.
if isnil l then 0 else plus (hd l) (s (tl l)));

mylist = cons 2 (cons 3 (cons 5 nil));

sumlist mylist;

T = Nat->Nat;
lambda f:T. lambda x:Nat. f (f x);

lambda x:A. x;


program test_brent

use types, only: dp
use optimize, only: brent, bracket
use utils, only: assert
implicit none
real(dp) :: xmin, fxmin, eps, xa, xb, xc, fa, fb, fc
eps = 1e-12_dp

call brent(f1, -1._dp, 0.5_dp, 1._dp, eps, 20, xmin, fxmin)
call assert(abs(xmin - 0) < eps)
call brent(f1, -1._dp, 0._dp, 1._dp, eps, 20, xmin, fxmin)
call assert(abs(xmin - 0) < eps)

! For some reason, this test needs tighter 'eps':
call brent(f2, -4._dp, 0._dp, 4._dp, eps/2, 30, xmin, fxmin)
call assert(abs(xmin - 0.865474033101_dp) < eps)
call brent(f2, -4._dp, 1._dp, 4._dp, eps, 30, xmin, fxmin)
call assert(abs(xmin - 0.865474033101_dp) < eps)

xa = -4
xb = -3
call bracket(f2, xa, xb, xc, fa, fb, fc, 100._dp, 20)
call brent(f2, xa, xb, xc, eps, 30, xmin, fxmin)
call assert(abs(xmin - 0.865474033101_dp) < eps)

contains

real(dp) function f1(x) result(y)
real(dp), intent(in) :: x
y = x**2
end function

real(dp) function f2(x) result(y)
real(dp), intent(in) :: x
y = (cos(x) - x**3)**2
end function

end program


c
c program polarect2
c
      include 'VICMAIN_FOR'
      subroutine main44

      parameter (maxnl=3002,maxns=3002)

      integer*4 ounit,def,count,status,unit,samp
      real*4 buf(maxns,maxnl),obuf(maxns)
      real*4 center(2)
      logical xvptst,interp

c checks
      call xveaction('SA',' ')

c open input
      call xvunit(unit,'INP',1,status,' ')
      call xvopen(unit,status,'U_FORMAT','REAL',' ')
      call xvget(unit,status,'NL',nl,'NS',ns,' ')
      if(ns.gt.maxns)then
        call xvmessage('Input image line too long',' ')
        call abend
      endif
      if(nl.gt.maxnl)then
        call xvmessage('Input image column too long',' ')
        call abend
      endif

c parameters
      pi=3.14159265
      call xvparm('NL',nlo,count,def,1)
      call xvparm('NS',nso,count,def,1)
      call xvparm('CENTER',center,count,def,2)
      if(xvptst('INTERP'))then
        interp=.true.
        write(*,*)'Using bilinear interpolation'
      else
        interp=.false.
        write(*,*)'Using nearest neighbor'
      endif

c open output
      call xvunit(ounit,'OUT',1,status,' ')
      call xvopen(ounit,status,'U_FORMAT','REAL','OP','WRITE',
     +  'U_NL',nlo,'U_NS',nso,' ')

c copy input into memory
      do line=1,nl
        call xvread(unit,buf(1,line),status,' ')
      enddo

c create polar image
      if(xvptst('direct'))then
        nl1=nl-1
        ns1=ns-1
        degpline=2.0*pi/nlo
        do line=1,nlo
          theta=(line-1)*degpline
          sinth=sin(theta)
          costh=cos(theta)
          do samp=1,nso
            y=(samp-1)*sinth+center(1)
            x=(samp-1)*costh+center(2)
            if(interp)then ! interpolate
              j=y
              i=x
              if((j.gt.0).and.(j.le.nl1).and.(i.gt.0).and.(i.le.ns1))
     +        then
                top=buf(i+1,j)*(x-i)+buf(i,j)*(i+1.-x)
                bot=buf(i+1,j+1)*(x-i)+buf(i,j+1)*(i+1.-x)
                obuf(samp)=top*(j+1.-y)+bot*(y-j)
              else
                obuf(samp)=0
              endif
            else ! no interpolate
              j=nint(y)
              i=nint(x)
              if((j.gt.0).and.(j.le.nl1).and.(i.gt.0).and.(i.le.ns1))
     +        then
                obuf(samp)=buf(i,j)
              else
                obuf(samp)=0
              endif
            endif
          enddo
          call xvwrit(ounit,obuf,status,' ')
        enddo
      endif

c create cartesian image
      if(xvptst('inverse'))then
        do i=1,ns
          buf(i,nl+1)=buf(i,1)  ! copy first line at end
        enddo
        nl1=nl
        ns1=ns-1
        degpline=2.0*pi/nl
        do line=1,nlo
          do samp=1,nso
            radius=sqrt((line-center(1))**2+(samp-center(2))**2)
            if(radius.gt..001)then
              theta=atan2(line-center(1),samp-center(2))
            else
              theta=pi
            endif
            if(theta.lt.0.0)theta=2.0*pi+theta
            y=theta/degpline+1.0
            x=radius+1.0
            if(interp)then ! interpolate
              j=y
              i=x
              if((j.gt.0).and.(j.le.nl1).and.(i.gt.0).and.(i.le.ns1))
     +        then
                top=buf(i+1,j)*(x-i)+buf(i,j)*(i+1.-x)
                bot=buf(i+1,j+1)*(x-i)+buf(i,j+1)*(i+1.-x)
                obuf(samp)=top*(j+1.-y)+bot*(y-j)
              else
                obuf(samp)=0
              endif
            else  ! no interpolate
              j=nint(y)
              i=nint(x)
              if((j.gt.0).and.(j.le.nl1).and.(i.gt.0).and.(i.le.ns1))
     +        then
                obuf(samp)=buf(i,j)
              else
                obuf(samp)=0
              endif
            endif
          enddo
          call xvwrit(ounit,obuf,status,' ')
        enddo
      endif

      return
      end


program ch0511
    ! Literal Real Constants in a Calculation
    use iso_fortran_env
    implicit none

    integer, parameter :: dp = real64
    real, parameter :: pi = 3.1415926535897931
    real(dp), parameter :: pid = 3.1415926535897931_dp
    real :: area, r = 2.
    real(dp) :: aread, rd = 2._dp

    area = pi*r*r
    aread = pid*rd*rd
    print 100, r, rd
    print 110, area, aread

100 format ('r     = ', f22.18, /, 'rd    = ', &
    f22.18)
110 format ('area  = ', f22.18, /, 'aread = ', &
    f22.18, /, 16x, '  ######')
end program


Program P3
	Implicit none
	real*8 :: dt, min, max, t
	real*8, dimension(2) :: y

	! inteval
	min=0.0D0
	max=10.0D0

	!time step
	dt=0.1D0
	! initial position
	y(1)=1.0D0
	! initial velocity
	y(2)=0.0D0

	Open(6, File='p3.dat')
	! Runga-Kutta iteration
	Do t=min, max, dt
		Call rk4(t, dt, y, 2)
		Write (6,*) t, y(1) ! y(1): x, pos
	enddo

	Close(6)
End program P3

! 4th-order Runge-Kutta subroutine
Subroutine rk4(t, dt, y, n)
	Implicit none
	real*8, external :: df, dg
	real*8 :: h, k0, k1, k2, k3, l0, l1, l2, l3
	real*8, intent(in) :: t, dt
	real*8, intent(inout), dimension(2) :: y
	integer, intent(in) :: n

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

! function which returns the derivatives (RHS)
real*8 function df(y,z)
! dx/dt = v(t)
	Implicit none
	real*8 ,intent(in) :: y, z
	df=z
	Return
End function df

real*8 Function dg(y,z)
! dv/dt = -w**2*x(t) -a*v
! the second term is damping term
	implicit none
	real*8, intent(in) :: y, z
	real*8 :: omega, alpha
	data omega /3.0d0/
	data alpha /0.5d0/

	dg= - omega**2.0d0 * y - alpha * z
	Return
End function dg


!***********************************************************************
!                                                                      *
      SUBROUTINE Y_K_DK (K,KM,GTheta,Phi,VAL_REAL,VAL_IM)
!                                                                      *
!     Calculates the spheric function Y^k _q by its algebraic formulae *
!     (see  subsection 5.2  Eq. (1) page 133 in                        *
!     D.A. Varshalovich, A.N. Moskalev and V.K. Khersonskii,           *
!     Quantum Theory of Angular Momentum; Berkeley, CA, 1981).         *
!                                                                      *
!     Written by D. Kato and G. Gaigalas                               *
!                                        NIFS, Japan, September 2013   *
!     The last modification made by G. Gaigalas       June      2018   *
!                                                                      *
!***********************************************************************
!
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE FACTS_C
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE plgndr_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN)       :: K, KM
      REAL(DOUBLE), INTENT(IN)  :: GTheta, Phi
      REAL(DOUBLE), INTENT(OUT) :: VAL_REAL, VAL_IM
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
!      INTEGER, PARAMETER :: MFACT = 500
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!----------------------------------------------
      INTEGER      :: KMM, KMP
      REAL(DOUBLE) :: PI, PK, X, FACT0, FACT
!----------------------------------------------
!
      pi=4.d0*datan(1.d0)
      fact0=0.25d0*dble(2*K+1)/pi
      kmm=K-abs(KM)
      kmp=K+abs(KM)
!GG      fact=fact0*factrl(kmm)/factrl(kmp)
      fact=fact0*DEXP(GAM(kmm+1))/DEXP(GAM(kmp+1))
      fact=dsqrt(fact)
!
!      CALL Y_K (K,KM,GTheta,Phi,VAL_REAL,VAL_IM)
!
      x=dcos(GTheta)
      pk=plgndr(K,abs(KM),x)
      VAL_REAL=fact*pk*dcos(KM*Phi)
      VAL_IM=fact*pk*dsin(KM*Phi)
      if (KM < 0) then
        VAL_REAL=VAL_REAL*(1-2*mod(abs(KM),2))
        VAL_IM=VAL_IM*(1-2*mod(abs(KM),2))
      end if
!
      RETURN
      END SUBROUTINE Y_K_DK


      PROGRAM TEST
      USE FMZM
      IMPLICIT NONE

!   Sample root-finding program.

!   FM_SECANT is a multiple precision root-finding routine.

!   The equation to be solved is  F(X,NF) = 0.
!   X  is the argument to the function.
!   NF is the function number in case roots to several functions are needed.

      CHARACTER(80) :: ST1
      TYPE (FM), SAVE     :: A1, A2, ROOT
      TYPE (FM), EXTERNAL :: F

!             Set the FM precision to 50 significant digits (plus a few "guard digits").

      CALL FM_SET(50)

!             Find a root of the first function,  X**2 - 3 = 0.
!             A1, A2 are two initial guesses for the root.

      A1 = 1
      A2 = 2

!             For this call no trace output will be done (KPRT = 0).
!             KU = 6 is used, so any error messages will go to the screen.

      WRITE (*,*) ' '
      WRITE (*,*) ' '
      WRITE (*,*) ' Case 1.  Call FM_SECANT to find a root between 1 and 2'
      WRITE (*,*) '          for f(x) = X**2 - 3.'
      WRITE (*,*) '          Use KPRT = 0, so no output will be done in the routine, then'
      WRITE (*,*) '          write the results from the main program.'

      CALL FM_SECANT(A1,A2,F,1,ROOT,0,6)

!             Write the result, using F35.30 format.

      CALL FM_FORM('F35.30',ROOT,ST1)
      WRITE (*   ,"(/'  A root for function 1 is ',A)") TRIM(ST1)

!             Find a root of the second function,  X*tan(X) - 1 = 0.  There are infinitely many
!             roots, and from the graph we decide to find the one between 6 and 7.

!             This time we ask for 50 digits of the root, and use FM_SECANT's built-in trace
!             (KPRT = 1) to print the final approximation to the root.  The output will appear on
!             more than one line, to allow for the possibility that precision could be hundreds or
!             thousands of digits, so the number might not fit on one line.

      WRITE (*,*) ' '
      WRITE (*,*) ' '
      WRITE (*,*) ' Case 2.  Find a root between 6 and 7 for  f(x) = x*tan(x) - 1.'
      WRITE (*,*) '          Use KPRT = 1, so FM_SECANT will print the result.'

      CALL FM_SECANT(TO_FM('6.0D0'),TO_FM('7.0D0'),F,2,ROOT,1,6)

!             Find a root of the third function,  gamma(x) - 10 = 0.  There is one root larger
!             than 1, and since gamma(5) is 24 this root is less than 5.

!             Get 50 digits of the root, and use FM_SECANT's built-in trace to print all
!             iterations (KPRT = 2) as well as the final approximation to the root.

      WRITE (*,*) ' '
      WRITE (*,*) ' '
      WRITE (*,*) ' Case 3.  Find a root between 1 and 5 for  f(x) = gamma(x) - 10.'
      WRITE (*,*) '          Use KPRT = 2, so FM_SECANT will print all iterations,'
      WRITE (*,*) '          as well as the final result.'

      CALL FM_SECANT(TO_FM(" 1.0 "),TO_FM(" 5.0 "),F,3,ROOT,2,6)

!             Find a root of the fourth function,  polygamma(0,x) = 0.
!             This root is the location of the one positive relative minimum for gamma(x),
!             since the derivative of gamma(x) is gamma(x)*polygamma(0,x).

!             Get 50 digits of the root, and use KPRT = 1 to print the root.

      WRITE (*,*) ' '
      WRITE (*,*) ' '
      WRITE (*,*) ' Case 4.  Find a root between 1 and 2 for  f(x) = polygamma(0,x).'
      WRITE (*,*) '          Use KPRT = 1, so FM_SECANT will print the result.'

      CALL FM_SECANT(TO_FM(" 1.0 "),TO_FM(" 2.0 "),F,4,ROOT,1,6)

!             Find a root of the fifth function,  cos(x) + 1 = 0.
!             This root has multiplicity 2 at x = pi.

!             Get 50 digits of the root, and use KPRT = 2 to print the iterations.

      WRITE (*,*) ' '
      WRITE (*,*) ' '
      WRITE (*,*) ' Case 5.  Find a root near 3.1 for  f(x) = cos(x) + 1.  (Double root)'
      WRITE (*,*) '          Use KPRT = 2, so FM_SECANT will print the iterations.'

      CALL FM_SECANT(TO_FM(" 3.1 "),TO_FM(" 3.2 "),F,5,ROOT,2,6)

!             Find a root of the sixth function,  cos(x) + 1 - 1.0D-40 = 0.
!             There are two different roots that agree to about 20 digits, so here
!             the convergence is slower.

!             Get 50 digits of the root, and use KPRT = 1 to print the root.

      WRITE (*,*) ' '
      WRITE (*,*) ' '
      WRITE (*,*) ' Case 6.  Find a root near 3.1 for  f(x) = cos(x) + 1 - 1.0E-40.'
      WRITE (*,*) '          There are two different roots that agree to about 20 digits,'
      WRITE (*,*) '          so here the convergence is slower.'
      WRITE (*,*) '          Use KPRT = 1, so FM_SECANT will print the result.'

      CALL FM_SECANT(TO_FM(" 3.1 "),TO_FM(" 3.2 "),F,6,ROOT,1,6)

!             Find a root of the seventh function,  sin(x) + ( x - pi ) = 0.
!             This root has multiplicity 3 at x = pi.

!             Get 50 digits of the root, and use KPRT = 2 to print the iterations.

      WRITE (*,*) ' '
      WRITE (*,*) ' '
      WRITE (*,*) ' Case 7.  Find a root near 3.1 for  f(x) = sin(x)**3.  (Triple root)'
      WRITE (*,*) '          Use KPRT = 2, so FM_SECANT will print the iterations.'

      CALL FM_SECANT(TO_FM(" 3.1 "),TO_FM(" 3.2 "),F,7,ROOT,2,6)

      WRITE (*,*) ' '

      END PROGRAM TEST

      FUNCTION F(X,NF)     RESULT (RETURN_VALUE)
      USE FMZM
      IMPLICIT NONE

!  X  is the argument to the function.
!  NF is the function number.

      INTEGER :: NF
      TYPE (FM) :: RETURN_VALUE, X

      IF      (NF == 1) THEN
          RETURN_VALUE = X*X - 3
      ELSE IF (NF == 2) THEN
          RETURN_VALUE = X*TAN(X) - 1
      ELSE IF (NF == 3) THEN
          RETURN_VALUE = GAMMA(X) - 10
      ELSE IF (NF == 4) THEN
          RETURN_VALUE = POLYGAMMA(0,X)
      ELSE IF (NF == 5) THEN
          RETURN_VALUE = COS(X) + 1
      ELSE IF (NF == 6) THEN
          RETURN_VALUE = COS(X) + (1 - TO_FM(' 1.0D-40 '))
      ELSE IF (NF == 7) THEN
          RETURN_VALUE = SIN(X)**3
      ELSE
          RETURN_VALUE = 3*X - 2
      ENDIF

      END FUNCTION F


!> \file
MODULE stel_constants

  USE stel_kinds, ONLY: rprec, dp

  implicit none

!----------------------------------------------------------------------
!  Mathematical constants
!----------------------------------------------------------------------

  REAL(dp), PARAMETER :: pi=3.14159265358979323846264338328_dp
  REAL(dp), PARAMETER :: pio2=pi/2
  REAL(dp), PARAMETER :: twopi=2*pi
  REAL(dp), PARAMETER :: sqrt2=1.41421356237309504880168872_dp
  REAL(dp), PARAMETER :: degree=twopi / 360
  REAL(dp), PARAMETER :: one=1
  REAL(dp), PARAMETER :: zero=0

!----------------------------------------------------------------------
!  Physical constants
!------------------------------------------------------------------

  REAL(dp), PARAMETER :: mu0 = 2 * twopi * 1.0e-7_dp

END MODULE stel_constants


      PROGRAM TEST

!   This is a sample program using version 1.4 of the FMZM and FM_RATIONAL_ARITHMETIC modules
!   for doing exact rational arithmetic using the FM_RATIONAL derived type.

!   The program's output to the screen is also saved in file SampleFMrational.out.
!   The program checks all the results and the last line of the output file should be
!   "All results were ok."

      USE FMVALS
      USE FMZM
      USE FM_RATIONAL_ARITHMETIC

      IMPLICIT NONE

!             Declare the multiple precision variables.  The three types used in this program are:
!             (FM) for multiple precision real
!             (IM) for multiple precision integer
!             (FM_RATIONAL) for multiple precision rational

      TYPE (FM), SAVE                       :: DET_FM, ERROR, MAX_REL_ERROR
      TYPE (FM), SAVE, ALLOCATABLE          :: A_FM(:,:), B_FM(:), C_FM(:,:), X_FM(:)
      TYPE (IM), SAVE                       :: C1, C2
      TYPE (FM_RATIONAL), SAVE              :: CHECK, DET_RM, F_RM, T_RM
      TYPE (FM_RATIONAL), SAVE, ALLOCATABLE :: A_RM(:,:), B_RM(:), C_RM(:,:), X_RM(:)

!             Declare the other variables (not multiple precision).

      CHARACTER(80)  :: ST1
      CHARACTER(175) :: FMT
      INTEGER :: I, I_MAX, J, J_MAX, K, KOUT, KW_SAVE, N, KERROR, NERROR, P(4), Q(4),  &
                 ROOTS_FOUND
      REAL :: T1, T2
      DOUBLE PRECISION :: VALUE

!             Write output to the screen (unit *), and also to the file SampleFMrational.out.

      KOUT = 18
      OPEN (KOUT,FILE='SampleFMrational.out')

!             KW is the unit used for all automatically generated output from the FM routines.
!             This includes calls to the various print routines, as well as error messages.
!             KW should also default to screen output.

      KW_SAVE = KW

      CALL FM_SET(50)
      CALL FM_SETVAR(' KSWIDE = 100 ')
      NERROR = 0

!             1.  Find all rational roots of the equation
!                 f(t) = 21*t**5 + 43*t**4 - 113*t**3 - 46*t**2 + 49*t + 10 = 0.

!                 The rational root theorem says that if a polynomial with integer
!                 coefficients has rational roots, they must be of the form p/q where
!                 p divides the constant term (10 here) and q divides the high-order
!                 coefficient (21 here).

!                 This gives a short list of possibilities that can be quickly checked.
!                 p could be + or - { 1, 2, 5, 10 }, and q could be { 1, 3, 7, 21 }.
!                 That gives 2*4*4 = 32 possible roots to check.

!                 TO_FM_RATIONAL is a conversion function for creating FM_RATIONAL numbers.
!                 There are several versions, including 1 or 2 integer arguments, 1 or 2
!                 string arguments, etc.  See the user manual for all the options.

      FMT = "(///' Sample 1.  Find all rational roots: " //  &
            " f(t) = 21*t**5 + 43*t**4 - 113*t**3 - 46*t**2 + 49*t + 10 = 0'/)"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)

      P = (/ 1, 2, 5, 10 /)
      Q = (/ 1, 3, 7, 21 /)
      ROOTS_FOUND = 0
      DO I = 2, 1, -1
         DO J = 1, 4
            DO K = 1, 4
               T_RM = (-1)**I * TO_FM_RATIONAL( P(J), Q(K) )
               F_RM = 21*T_RM**5 + 43*T_RM**4 - 113*T_RM**3 - 46*T_RM**2 + 49*T_RM + 10
               IF (F_RM == 0) THEN
                   WRITE (*   ,"(A)") "    Exact rational root found:"
                   CALL FM_PRINT_RATIONAL( T_RM )
                   WRITE (KOUT,"(A)") "    Exact rational root found:"
                   KW = KOUT
                   CALL FM_PRINT_RATIONAL( T_RM )
                   KW = KW_SAVE

!                  Check the results.

                   ROOTS_FOUND = ROOTS_FOUND + 1
                   IF (ROOTS_FOUND == 1) THEN
                       IF (.NOT.(T_RM == TO_FM_RATIONAL(' 2/3 '))) THEN
                           NERROR = NERROR + 1
                       ENDIF
                   ELSE IF (ROOTS_FOUND == 2) THEN
                       IF (.NOT.(T_RM == TO_FM_RATIONAL(' -5 / 7 '))) THEN
                           NERROR = NERROR + 1
                       ENDIF
                   ELSE IF (ROOTS_FOUND > 2) THEN
                           NERROR = NERROR + 1
                   ENDIF
               ENDIF
            ENDDO
         ENDDO
      ENDDO

      IF (NERROR > 0 .OR. ROOTS_FOUND /= 2) THEN
          WRITE (*   ,"(/' Error in sample case number 1.'/)")
          WRITE (KOUT,"(/' Error in sample case number 1.'/)")
      ENDIF

!             2.  Exact solution of linear systems (integer coefficients)

!                 Many linear systems of equations have integer coefficients, making the solutions
!                 rational.  Others have rational coefficients, also giving rational solutions.

!                 Generate several systems of the type that come from some kinds of least-squares
!                 problems.

!                 The coefficient matrix is NxN for N = 25, 50, 75, 100.

!                 Compare the accuracy and speed of the floating-point routine FM_LIN_SOLVE
!                 with the exact rational routine RM_LIN_SOLVE.

!                 Note that for systems with integer coefficients, it can be faster to find
!                 the exact rational solution than to find a 50-digit approximate solution,
!                 even though in the 100x100 case the numerators and denominators have over
!                 200 digits each.

      FMT = "(///' Sample 2.  Solve four NxN linear systems having small integer coefficients.')"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)
      KERROR = 0

      DO N = 25, 100, 25
         WRITE (*   ,*) ' '
         WRITE (KOUT,*) ' '
         ALLOCATE(A_FM(N,N), B_FM(N), X_FM(N), A_RM(N,N), B_RM(N), X_RM(N))

         A_FM = 0
         B_FM = 0
         X_FM = 0
         A_RM = 0
         B_RM = 0
         X_RM = 0
         DO J = 1, N*N
            CALL FM_RANDOM_NUMBER(VALUE)
            I = N*VALUE + 1
            CALL FM_RANDOM_NUMBER(VALUE)
            K = N*VALUE + 1
            A_RM(I,I) = A_RM(I,I) + 1
            A_RM(I,K) = A_RM(I,K) - 1
            A_RM(K,K) = A_RM(K,K) + 1
            A_RM(K,I) = A_RM(K,I) - 1
            CALL FM_RANDOM_NUMBER(VALUE)
            B_RM(I) = B_RM(I) + (I-K) + INT(12*VALUE - 6)
            B_RM(K) = B_RM(K) - (I-K) + INT(12*VALUE - 6)
         ENDDO
         A_RM(N,1:N) = 0
         A_RM(N,N) = 1
         B_RM(N) = N
         A_FM = TO_FM( A_RM )
         B_FM = TO_FM( B_RM )

!             Solve the system with floating-point 50 significant arithmetic.

!             Routines with names like FM_LIN_SOLVE_RM are copies of the corresponding routines
!             (FM_LIN_SOLVE here) from the standard floating-point FM sample routine file.  The
!             ones with names ending "_RM" are available in the FM_RATIONAL_ARITHMETIC module.

         CALL CPU_TIME(T1)
         CALL FM_LIN_SOLVE_RM(A_FM, X_FM, B_FM, N, DET_FM)
         CALL CPU_TIME(T2)

         FMT = "(/'    FM_LIN_SOLVE approximate solution for ',I4,' x',I4,' system in',"//  &
               "F12.2,' seconds.')"
         WRITE (*   ,FMT) N, N, T2-T1
         WRITE (KOUT,FMT) N, N, T2-T1
         WRITE (*   ,*) '             Determinant ='
         WRITE (KOUT,*) '             Determinant ='
         CALL FM_PRINT(DET_FM)
         KW = KOUT
         CALL FM_PRINT(DET_FM)
         KW = KW_SAVE
         WRITE (*   ,*) '             X(1) ='
         WRITE (KOUT,*) '             X(1) ='
         CALL FM_PRINT(X_FM(1))
         KW = KOUT
         CALL FM_PRINT(X_FM(1))
         KW = KW_SAVE

!             Solve the system with exact rational arithmetic.

         CALL CPU_TIME(T1)
         CALL RM_LIN_SOLVE(A_RM, X_RM, B_RM, N, DET_RM)
         CALL CPU_TIME(T2)

         FMT = "(/'    RM_LIN_SOLVE       exact solution for ',I4,' x',I4,' system in',"//  &
               "F12.2,' seconds.')"
         WRITE (*   ,FMT) N, N, T2-T1
         WRITE (KOUT,FMT) N, N, T2-T1
         WRITE (*   ,*) '             Determinant ='
         WRITE (KOUT,*) '             Determinant ='
         CALL FM_PRINT_RATIONAL(DET_RM)
         KW = KOUT
         CALL FM_PRINT_RATIONAL(DET_RM)
         KW = KW_SAVE
         WRITE (*   ,*) '             X(1) ='
         WRITE (KOUT,*) '             X(1) ='
         CALL FM_PRINT_RATIONAL(X_RM(1))
         KW = KOUT
         CALL FM_PRINT_RATIONAL(X_RM(1))
         KW = KW_SAVE

!                  Check the results.

         IF (.NOT.(ABS(DET_FM - TO_FM(DET_RM)) <= 1.0D-45*ABS(DET_FM))) THEN
             KERROR = KERROR + 1
         ENDIF
         DO J = 1, N
            IF (.NOT.(ABS(X_FM(J) - TO_FM(X_RM(J))) < 1.0D-45)) THEN
                KERROR = KERROR + 1
            ENDIF
         ENDDO

         DEALLOCATE(A_FM, B_FM, X_FM, A_RM, B_RM, X_RM)
      ENDDO

      IF (KERROR > 0) THEN
          WRITE (*   ,"(/' Error in sample case number 2.'/)")
          WRITE (KOUT,"(/' Error in sample case number 2.'/)")
          NERROR = NERROR + 1
      ENDIF

!             3.  Exact solution of linear systems (rational coefficients).

!                 Modify sample 2 so that the coefficients are rationals with numerators and
!                 denominators having no more than 2 digits.

!                 This causes the number of digits in the rational solution's numerators and
!                 denominators to get much larger, slowing RM_LIN_SOLVE compared to FM_LIN_SOLVE.

!                 Use smaller N's for the coefficient matrix here: NxN for N = 10, 20, 30, 40.

      FMT = "(///' Sample 3.  Solve four NxN linear systems, this time having non-integer" //  &
            " rational coefficients.'/)"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)
      KERROR = 0

      DO N = 10, 40, 10
         WRITE (*   ,*) ' '
         WRITE (KOUT,*) ' '
         ALLOCATE(A_FM(N,N), B_FM(N), X_FM(N), A_RM(N,N), B_RM(N), X_RM(N))

         A_FM = 0
         B_FM = 0
         X_FM = 0
         A_RM = 0
         B_RM = 0
         X_RM = 0
         DO J = 1, N*N
            CALL FM_RANDOM_NUMBER(VALUE)
            I = N*VALUE + 1
            CALL FM_RANDOM_NUMBER(VALUE)
            K = N*VALUE + 1
            A_RM(I,I) = A_RM(I,I) + TO_FM_RATIONAL( I, ABS(K) + 1 )
            A_RM(I,K) = A_RM(I,K) - TO_FM_RATIONAL( I, ABS(K) + 1 )
            A_RM(K,K) = A_RM(K,K) + TO_FM_RATIONAL( I, ABS(K) + 1 )
            A_RM(K,I) = A_RM(K,I) - TO_FM_RATIONAL( I, ABS(K) + 1 )
            CALL FM_RANDOM_NUMBER(VALUE)
            B_RM(I) = B_RM(I) + (I-K) + INT(12*VALUE - 6)
            B_RM(K) = B_RM(K) - (I-K) + INT(12*VALUE - 6)
         ENDDO
         A_RM(N,1:N) = 0
         A_RM(N,N) = 1
         B_RM(N) = N
         A_FM = TO_FM( A_RM )
         B_FM = TO_FM( B_RM )

!             Solve the system with floating-point 50 significant arithmetic.

         CALL CPU_TIME(T1)
         CALL FM_LIN_SOLVE_RM(A_FM, X_FM, B_FM, N, DET_FM)
         CALL CPU_TIME(T2)

         FMT = "(/'    FM_LIN_SOLVE approximate solution for ',I4,' x',I4,' system in',"//  &
               "F12.2,' seconds.')"
         WRITE (*   ,FMT) N, N, T2-T1
         WRITE (KOUT,FMT) N, N, T2-T1
         WRITE (*   ,*) '             Determinant ='
         WRITE (KOUT,*) '             Determinant ='
         CALL FM_PRINT(DET_FM)
         KW = KOUT
         CALL FM_PRINT(DET_FM)
         KW = KW_SAVE
         WRITE (*   ,*) '             X(1) ='
         WRITE (KOUT,*) '             X(1) ='
         CALL FM_PRINT(X_FM(1))
         KW = KOUT
         CALL FM_PRINT(X_FM(1))
         KW = KW_SAVE

!             Solve the system with exact rational arithmetic.

         CALL CPU_TIME(T1)
         CALL RM_LIN_SOLVE(A_RM, X_RM, B_RM, N, DET_RM)
         CALL CPU_TIME(T2)

         FMT = "(/'    RM_LIN_SOLVE       exact solution for ',I4,' x',I4,' system in',"//  &
               "F12.2,' seconds.')"
         WRITE (*   ,FMT) N, N, T2-T1
         WRITE (KOUT,FMT) N, N, T2-T1
         WRITE (*   ,*) '             Determinant ='
         WRITE (KOUT,*) '             Determinant ='
         CALL FM_PRINT_RATIONAL(DET_RM)
         KW = KOUT
         CALL FM_PRINT_RATIONAL(DET_RM)
         KW = KW_SAVE
         WRITE (*   ,*) '             X(1) ='
         WRITE (KOUT,*) '             X(1) ='
         CALL FM_PRINT_RATIONAL(X_RM(1))
         KW = KOUT
         CALL FM_PRINT_RATIONAL(X_RM(1))
         KW = KW_SAVE

!                  Check the results.

         IF (.NOT.(ABS(DET_FM - TO_FM(DET_RM)) <= 1.0D-45*ABS(DET_FM))) THEN
             KERROR = KERROR + 1
         ENDIF
         DO J = 1, N
            IF (.NOT.(ABS(X_FM(J) - TO_FM(X_RM(J))) < 1.0D-45)) THEN
                KERROR = KERROR + 1
            ENDIF
         ENDDO

         DEALLOCATE(A_FM, B_FM, X_FM, A_RM, B_RM, X_RM)
      ENDDO

      IF (KERROR > 0) THEN
          WRITE (*   ,"(/' Error in sample case number 3.'/)")
          WRITE (KOUT,"(/' Error in sample case number 3.'/)")
          NERROR = NERROR + 1
      ENDIF

!             4.  Exact matrix inverse.

!                 One possible use for exact rational arithmetic is in looking for patterns
!                 in the answers.

!                 For an example, there is a formula for the determinant of the Hilbert matrix,
!                     a(j,k) = 1 / ( j + k - 1 ).
!                 We might have a similar matrix where no formula is known and we could try
!                 to discover one by examining factorizations of numerator and denominator.

!                 Try this for the Hilbert matrix with N = 1, 2, ..., 5

!                 N =             1         2             3                 4                    5
!                 det = 1 /       1        12          2160           6048000         266716800000
!                 factorization:  1     2^2 3     2^4 3^3 5     2^8 3^3 5^3 7     2^10 3^5 5^5 7^3

!                 There are some clues that might help us guess a formula, but the first thing
!                 to try is the On-line Encyclopedia of Integer Sequences, https://oeis.org/
!                 entering   1, 12, 2160, 6048000, 266716800000   produces several references
!                 to the inverse Hilbert matrix, where we can find a formula.

      FMT = "(///' Sample 4.  Examine determinants of several small Hilbert matrices.'/)"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)
      KERROR = 0

      DO N = 1, 5
         WRITE (*   ,*) ' '
         WRITE (KOUT,*) ' '
         ALLOCATE(A_FM(N,N), C_FM(N,N), A_RM(N,N), C_RM(N,N))

         A_FM = 0
         C_FM = 0
         A_RM = 0
         C_RM = 0
         DO J = 1, N
            DO K = 1, N
               A_RM(J,K) = TO_FM_RATIONAL( 1, J+K-1 )
            ENDDO
         ENDDO
         A_FM = TO_FM( A_RM )

!             Invert the matrix with floating-point 50 significant arithmetic.

         CALL CPU_TIME(T1)
         CALL FM_INVERSE_RM(A_FM, N, C_FM, DET_FM)
         CALL CPU_TIME(T2)

         FMT = "(/'    FM_INVERSE approximate inverse for ',I4,' x',I4,' matrix in',"//  &
               "F12.2,' seconds.')"
         WRITE (*   ,FMT) N, N, T2-T1
         WRITE (KOUT,FMT) N, N, T2-T1
         WRITE (*   ,*) '             Determinant ='
         WRITE (KOUT,*) '             Determinant ='
         CALL FM_PRINT(DET_FM)
         KW = KOUT
         CALL FM_PRINT(DET_FM)
         KW = KW_SAVE

!             Invert the matrix with exact rational arithmetic.

         CALL CPU_TIME(T1)
         CALL RM_INVERSE(A_RM, N, C_RM, DET_RM)
         CALL CPU_TIME(T2)

         FMT = "(/'    RM_INVERSE       exact inverse for ',I4,' x',I4,' matrix in',"//  &
               "F12.2,' seconds.')"
         WRITE (*   ,FMT) N, N, T2-T1
         WRITE (KOUT,FMT) N, N, T2-T1
         WRITE (*   ,*) '             Determinant ='
         WRITE (KOUT,*) '             Determinant ='
         CALL FM_PRINT_RATIONAL(DET_RM)
         KW = KOUT
         CALL FM_PRINT_RATIONAL(DET_RM)
         KW = KW_SAVE

!                  Check the results.

         IF (.NOT.(ABS(DET_FM - TO_FM(DET_RM)) <= 1.0D-45*ABS(DET_FM))) THEN
             KERROR = KERROR + 1
         ENDIF
         DO J = 1, N
            DO K = 1, N
               IF (.NOT.(ABS(C_FM(J,K) - TO_FM(C_RM(J,K))) < 1.0D-45)) THEN
                   KERROR = KERROR + 1
               ENDIF
            ENDDO
         ENDDO

         DEALLOCATE(A_FM, C_FM, A_RM, C_RM)
      ENDDO

      IF (KERROR > 0) THEN
          WRITE (*   ,"(/' Error in sample case number 4.'/)")
          WRITE (KOUT,"(/' Error in sample case number 4.'/)")
          NERROR = NERROR + 1
      ENDIF

!             5.  Exact matrix inverse.

!                 Use the Hilbert matrix with some larger values for N, and compare times with FM.

!                 There are two things to notice about this case:
!                 (1) The Hilbert matrix becomes so ill-conditioned as N increases that even
!                     carrying over 50 digits with floating-point arithmetic in FM_INVERSE
!                     is not enough.  The maximum relative error for elements of C_FM are:
!                         N =         10          20          30          40
!                         error =  1.09e-50    7.10e-36    1.15e-20    2.19e-5
!                     If we wanted 50-digit accuracy from FM_INVERSE for N=40, we would need
!                     to set precision to at least 100 digits.
!                 (2) The numerators and denominators in the Hilbert matrix are all fairly
!                     small, so the modular method is faster than FM_INVERSE, even though
!                     the exact numerators and denominators have more than 50 digits.
!                     Timing will vary, but a typical result is for RM_INVERSE to run in
!                     less than half the time of FM_INVERSE.  The determinant for N = 40
!                     has over 900 digits in the denominator, but the largest element in
!                     the (integer-valued) inverse matrix has only 58 digits.

      FMT = "(///' Sample 5.  Examine determinants of several larger Hilbert matrices.'/)"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)
      KERROR = 0

      DO N = 10, 40, 10
         WRITE (*   ,*) ' '
         WRITE (KOUT,*) ' '
         ALLOCATE(A_FM(N,N), C_FM(N,N), A_RM(N,N), C_RM(N,N))

         A_FM = 0
         C_FM = 0
         A_RM = 0
         C_RM = 0
         DO J = 1, N
            DO K = 1, N
               A_RM(J,K) = TO_FM_RATIONAL( 1, J+K-1 )
            ENDDO
         ENDDO
         A_FM = TO_FM( A_RM )

!             Invert the matrix with floating-point 50 significant arithmetic.

         CALL CPU_TIME(T1)
         CALL FM_INVERSE_RM(A_FM, N, C_FM, DET_FM)
         CALL CPU_TIME(T2)

         FMT = "(/'    FM_INVERSE approximate inverse for ',I4,' x',I4,' matrix in',"//  &
               "F12.2,' seconds.')"
         WRITE (*   ,FMT) N, N, T2-T1
         WRITE (KOUT,FMT) N, N, T2-T1
         WRITE (*   ,*) '             1 / Determinant ='
         WRITE (KOUT,*) '             1 / Determinant ='
         CALL FM_PRINT(1/DET_FM)
         KW = KOUT
         CALL FM_PRINT(1/DET_FM)
         KW = KW_SAVE

!             Invert the matrix with exact rational arithmetic.

         CALL CPU_TIME(T1)
         CALL RM_INVERSE(A_RM, N, C_RM, DET_RM)
         CALL CPU_TIME(T2)

         FMT = "(/'    RM_INVERSE       exact inverse for ',I4,' x',I4,' matrix in',"//  &
               "F12.2,' seconds.')"
         WRITE (*   ,FMT) N, N, T2-T1
         WRITE (KOUT,FMT) N, N, T2-T1
         WRITE (*   ,*) '             Determinant ='
         WRITE (KOUT,*) '             Determinant ='
         CALL FM_PRINT_RATIONAL(DET_RM)
         KW = KOUT
         CALL FM_PRINT_RATIONAL(DET_RM)
         KW = KW_SAVE

!                  Check the results.

!                  Because the Hilbert matrix is pathologically ill-conditioned, even using
!                  50 digits for the input to FM_INVERSE can give little accuracy in the
!                  solution.  Use the mathematically exact values to check the results
!                  from RM_INVERSE.

!                  The correct determinant of the Hilbert matrix is always 1 / integer

!                  = 1 / ( c(2n) / c(n)^4 ),  where c(n) = product( j^(n-j) ; j=1,n-1 )

         C1 = 1
         DO J = 1, N-1
            C1 = C1 * TO_IM(J)**TO_IM(N-J)
         ENDDO
         C2 = 1
         DO J = 1, 2*N-1
            C2 = C2 * TO_IM(J)**TO_IM(2*N-J)
         ENDDO
         C2 = C2 / C1**4
         IF (.NOT.(DET_RM == TO_FM_RATIONAL( TO_IM(1), C2 ))) THEN
             KERROR = KERROR + 1
             IF (KERROR == 1) THEN
                 WRITE (*   ,"(/' Error in determinant for sample case number 5.'/)")
                 WRITE (KOUT,"(/' Error in determinant for sample case number 5.'/)")
             ENDIF
         ENDIF

!                  The correct elements of the inverse Hilbert matrix are:

!                  c_rm(i,j) = (-1)^(i+j) * (i+j-1) * binomial(n+i-1,n-j) * binomial(n+j-1,n-i) *
!                                                     binomial(i+j-2,i-1)^2

         DO I = 1, N
            DO J = 1, N
               C1 = BINOMIAL(TO_FM(N+I-1),TO_FM(N-J)) * BINOMIAL(TO_FM(N+J-1),TO_FM(N-I))
               C2 = BINOMIAL(TO_FM(I+J-2),TO_FM(I-1))**2
               CHECK = (-1)**(I+J) * (I+J-1) * C1 * C2
               IF (.NOT.(C_RM(I,J) == CHECK)) THEN
                   KERROR = KERROR + 1
                   IF (KERROR == 1) THEN
                       WRITE (*   ,"(/' Error in inverse element for sample case number 5.'/)")
                       WRITE (KOUT,"(/' Error in inverse element for sample case number 5.'/)")
                   ENDIF
               ENDIF
            ENDDO
         ENDDO

!             Check how badly conditioned each matrix is by finding the least accurate element
!             in the computed inverse matrix from FM_INVERSE.
!             Use the relative error between C_FM and C_RM, since the numbers are large.

         MAX_REL_ERROR = -1
         DO I = 1, N
            DO J = 1, N
               ERROR = ABS( ( C_FM(I,J) - TO_FM(C_RM(I,J)) ) / TO_FM(C_RM(I,J)) )
               IF (ERROR > MAX_REL_ERROR) THEN
                   MAX_REL_ERROR = ERROR
                   I_MAX = I
                   J_MAX = J
               ENDIF
            ENDDO
         ENDDO

         FMT = "(/'    FM_INVERSE inverse matrix largest relative error"//   &
                    " was in row',I3,' column',I3,'.  Error =',A)"
         CALL FM_FORM('ES14.5',MAX_REL_ERROR,ST1)
         WRITE (*   ,FMT) I_MAX, J_MAX, ST1
         WRITE (KOUT,FMT) I_MAX, J_MAX, ST1

         DEALLOCATE(A_FM, C_FM, A_RM, C_RM)
      ENDDO

      IF (KERROR > 0) THEN
          WRITE (*   ,"(/' Error in sample case number 5.'/)")
          WRITE (KOUT,"(/' Error in sample case number 5.'/)")
          NERROR = NERROR + 1
      ENDIF

!             6.  Exact matrix inverse.

!                 Like sample 5, except use random A-matrices with numerators and denominators
!                 having no more than 2 digits.

      FMT = "(///' Sample 6.  Find four NxN inverse matrices, having random" //  &
            " 2-digit numerators and denominators.'/)"
      WRITE (*   ,FMT)
      WRITE (KOUT,FMT)
      KERROR = 0

      DO N = 10, 40, 10
         WRITE (*   ,*) ' '
         WRITE (KOUT,*) ' '
         ALLOCATE(A_FM(N,N), C_FM(N,N), A_RM(N,N), C_RM(N,N))

         A_FM = 0
         C_FM = 0
         A_RM = 0
         C_RM = 0
         DO I = 1, N
            DO J = 1, N
               CALL FM_RANDOM_NUMBER(VALUE)
               K = 198*VALUE - 99
               A_RM(I,J) = K
               CALL FM_RANDOM_NUMBER(VALUE)
               K = 99*VALUE + 1
               A_RM(I,J) = A_RM(I,J) / K
               A_FM(I,J) = TO_FM(A_RM(I,J))
            ENDDO
         ENDDO

!             Invert the matrix with floating-point 50 significant arithmetic.

         CALL CPU_TIME(T1)
         CALL FM_INVERSE_RM(A_FM, N, C_FM, DET_FM)
         CALL CPU_TIME(T2)

         FMT = "(/'    FM_INVERSE approximate solution for ',I4,' x',I4,' system in',"//  &
               "F12.2,' seconds.')"
         WRITE (*   ,FMT) N, N, T2-T1
         WRITE (KOUT,FMT) N, N, T2-T1
         WRITE (*   ,*) '             Determinant ='
         WRITE (KOUT,*) '             Determinant ='
         CALL FM_PRINT(DET_FM)
         KW = KOUT
         CALL FM_PRINT(DET_FM)
         KW = KW_SAVE

!             Invert the matrix with exact rational arithmetic.

         CALL CPU_TIME(T1)
         CALL RM_INVERSE(A_RM, N, C_RM, DET_RM)
         CALL CPU_TIME(T2)

         FMT = "(/'    RM_INVERSE       exact solution for ',I4,' x',I4,' system in',"//  &
               "F12.2,' seconds.')"
         WRITE (*   ,FMT) N, N, T2-T1
         WRITE (KOUT,FMT) N, N, T2-T1
         WRITE (*   ,*) '             Determinant ='
         WRITE (KOUT,*) '             Determinant ='
         CALL FM_PRINT_RATIONAL(DET_RM)
         KW = KOUT
         CALL FM_PRINT_RATIONAL(DET_RM)
         KW = KW_SAVE

!                  Check the results.

!                  These random matrices are not ill-conditioned, so the results can be checked
!                  by comparing the FM and RM inverses.

         IF (.NOT.(ABS(DET_FM - TO_FM(DET_RM)) <= 1.0D-45*ABS(DET_FM))) THEN
             KERROR = KERROR + 1
         ENDIF
         DO I = 1, N
            DO J = 1, N
               IF (.NOT.(ABS(C_FM(I,J) - TO_FM(C_RM(I,J))) < 1.0D-45)) THEN
                   KERROR = KERROR + 1
               ENDIF
            ENDDO
         ENDDO

         DEALLOCATE(A_FM, C_FM, A_RM, C_RM)
      ENDDO

      IF (KERROR > 0) THEN
          WRITE (*   ,"(/' Error in sample case number 6.'/)")
          WRITE (KOUT,"(/' Error in sample case number 6.'/)")
          NERROR = NERROR + 1
      ENDIF

      IF (NERROR == 0) THEN
          WRITE (*   ,"(//A/)") ' All results were ok -- no errors were found.'
          WRITE (KOUT,"(//A/)") ' All results were ok -- no errors were found.'
      ELSE
          WRITE (*   ,"(//I3,A/)") NERROR,' error(s) found.'
          WRITE (KOUT,"(//I3,A/)") NERROR,' error(s) found.'
      ENDIF

      STOP
      END PROGRAM TEST


      SUBROUTINE DTGC1  (NEWTRI, S, ZOUT, WANTDZ, DZOUT)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1996-02-02 DTGC1 CLL
C>> 1995-09-26 DTGC1 CLL Editing for inclusion into MATH77.
c     C.L.Lawson, JPL, 1976 Dec 7
c     This subr interpolates over a triangle using the piecewise
c     bicubic formulas of  Clough and Tocher (1965) as formulated for
c     computation by C.L.Lawson in JPL Tech. Memorandum 33-770, May,1976
c     This method gives C1 continuity with neighboring triangles, i.e.,
c     continuity of value and first partial derivatives.
c     Generally there will be jumps in second and higher order
c     derivatives across edges between triangles, and along implicit
c     edges that partition each triangle into three smaller triangles.
c     Optionally the subr also computes first partial derivatives.
c
c   NEWTRI [in]  This argument allows certain computations to be
c          skipped, saving 15 multiplies, 3 divides, and 9 adds,
c          when the user has made no changes to the contents of
c          columns 2, 3, 5, 6, 7, 8, & 9 of the S() array since a
c          previous call.  (Thus it is allowable to have changed the
c          contents of columns 1 and 4.)
c          Setting NEWTRI = .TRUE. causes these computations to be done,
c          while .FALSE. cause them to be skipped.
C
c   (S(1:3, 1:9) [inout]  Columns 1-6 contain data set by the user to
c          specify the interpolation problem.  Col 1 contains
c          unnormalized barycentric coordinates of the interpolation
c          point.  The other cols contain data depending only on the
c          triangle and its vertex data and not on the interpolation
c          point.  Cols 7-9 are computed by this subroutine, and in
c          appropriate cases can be saved from one call to the next.
c          See NEWTRI above.
c
c         S( ,1) = UNNORMALIZED BARYCENTRIC COORDS OF INTERP POINT.
c         S( ,2) = U = X COORD OF EDGE VECTOR
c         S( ,3) = V = Y COORD OF EDGE VECTOR
c         S( ,4) = Z = FCN VALUE AT VERTEX
c         S( ,5) = ZX = PARTIAL DERIV OF Z W.R.T. X
c         S( ,6) = ZY = PARTIAL DERIV OF Z W.R.T. Y
c         S( ,7) = HTILDA = SCALED P.D. TANGENTIAL TO EDGE AT LEFT END.
c         S( ,8) = KTILDA = SCALED P.D. TANGENTIAL TO EDGE AT RIGHT END.
c         S( ,9) = LFAC   = FACTOR INVOLVING LENGTHS OF EDGES.
c
c   ZOUT [out]  INTERPOLATED VALUE COMPUTED BY SUBR.
C
c   WANTDZ [in]  =.TRUE. MEANS COMPUTE DZOUT() AS WELL AS ZOUT.
c              =.FALSE. MEANS COMPUTE ONLY ZOUT AND NOT DZOUT().
C
c   DZOUT(1:2) [out]  FIRST PARTIAL DERIVS W.R.T. X AND Y OF THE
c              INTERPOLATED SURFACE AT THE INTERPOLATION POINT.
c     ------------------------------------------------------------------
c         Details of the contents of TRI(1:7) and S(1:3, 1:6).
c
c  We assume the point Q is in the triangle indexed by INDTRI.
c  The indices of the vertices of this triangle, in counter-
c  clockwise, order are P(1), P(2), and P(3) which may be obtained as
c  P(i) = TRI(3+i) for i = 1, 2, and 3.  TRI(7) contains the same
c  value as TRI(4).  The triangle adjacent to this triangle across
c  the edge from P(i) to P(i+1) is indexed by TRI(i) for i = 1, 2,
c  and 3.  If there is no adjacent triangle across this edge then
c  TRI(i) = 0.
c
c  For descriptive convenience we regard the subscript of P() and the
c  1st subsubscript of S(,) as always being reduced modulo 3 to 1, 2,
c  or 3.  Also for convenience we shall write P(i) to mean the vertex
c  indexed by P(i).
c
c  The unnormalized barycentric coordinate that is zero along the edge
c  from P(i) to P(i+1) and has a positive value at P(i+2) is stored in
c  S(i,1).  The (x,y) coordinates of the vector from P(i) to P(i+1) are
c  stored in (S(i,2), S(i,3)).
c  The function value Z at P(i+2) is stored in S(i,4) for i = 1, 2, & 3.
c  ZX, the partial deriv of Z w.r.t. X at P(i+2) is stored in S(i,5)
c     for i = 1, 2, & 3.
c  ZY, the partial deriv of Z w.r.t. Y at P(i+2) is stored in S(i,6)
c     for i = 1, 2, & 3.
c     ------------------------------------------------------------------
c--D replaces "?": ?TGC1
C     ------------------------------------------------------------------
      INTEGER          ADD1(3), i, im1, ip1, j, m, mm1, mp1, SUB1(3)
      DOUBLE PRECISION A, B, C
      double precision DA, DB, DC, DGTILD(3), DPHI(3)
      double precision DR(3), DRHO(3), DZOUT(2)
      double precision fac, GTILDA(3), LSQ(3)
      DOUBLE PRECISION r(3),  RHO(3), PHI(3), S(3,9), sum
      DOUBLE PRECISION zout
      LOGICAL  WANTDZ,NEWTRI
      DATA ADD1(1),ADD1(2),ADD1(3)/ 2, 3, 1 /
      DATA SUB1(1),SUB1(2),SUB1(3)/ 3, 1, 2 /
C     ------------------------------------------------------------------
c              COMPUTE R() = NORMALIZED BARYCENTRIC COORDINATES.
c              AND LSQ()   = SQUARED EDGE LENGTHS
C
      FAC = 1.D00/(S(1,1)+S(2,1)+S(3,1))
      DO 10 I=1,3
         R(I) = FAC*S(I,1)
         LSQ(I)= S(I,2)**2 + S(I,3)**2
   10 continue
c                             COMPUTE PHI(I) = R(I+1) * R(I-1)
      PHI(1) = R(2)*R(3)
      PHI(2) = R(3)*R(1)
      PHI(3) = R(1)*R(2)
C
c              COMPUTE RHO() = CLOUGH-TOCHER PIECEWISE BICUBIC
c                              CORRECTION FUNCTION
C
      IF ( R(1) .LE. R(2)) THEN
      IF ( R(1) .LE. R(3)) THEN
            M = 1
      ELSE
            M = 3
      END IF
      ELSE
      IF ( R(2) .LE. R(3)) THEN
            M = 2
      ELSE
            M = 3
      END IF
      END IF
C
      A = 0.5D0 * R(M)**2
      B = (1.0D0/3.0D0)*R(M)
      C = PHI(M) + (5.0D0/3.0D0)*A
      RHO(M) = R(M) * C - A
      MP1 = ADD1(M)
      MM1 = SUB1(M)
      RHO(MP1) = A*(R(MM1) - B)
      RHO(MM1) = A*(R(MP1) - B)
C
      SUM = 0.0d0
        DO 20 I=1,3
         IP1 = ADD1(I)
         IM1 = SUB1(I)
C
         IF (NEWTRI ) THEN
c                                                               H TILDA
            S(I,7) = S(I,2)*S(IP1,5) + S(I,3)*S(IP1,6)
c                                                               K TILDA
            S(I,8) = S(I,2)*S(IM1,5) + S(I,3)*S(IM1,6)
c                                                               LFAC
            S(I,9) = 3.0D0*(LSQ(IP1)-LSQ(IM1)) / LSQ(I)
         END IF
c                                                               G TILDA
         GTILDA(I)= (R(IP1)-R(IM1))*PHI(I) + S(I,9)*RHO(I)
     *              -RHO(IP1)+RHO(IM1)
         SUM = SUM + S(I,7)*(GTILDA(I)+PHI(I))
     *             + S(I,8)*(GTILDA(I)-PHI(I))
   20 continue
      ZOUT = 0.5D0 * SUM
C
      DO 30 I=1,3
         IP1 = ADD1(I)
         IM1 = SUB1(I)
         ZOUT=ZOUT + S(I,4)*(R(I)+GTILDA(IM1)-GTILDA(IP1))
   30 continue
c                                  FINISHED COMPUTING ZOUT.
C
c                                  NOW COMPUTE DZOUT() IF REQUESTED.
      IF ( WANTDZ) THEN
         DO 100 J=1,2
            if(j .eq. 1) then
               DO 40 I=1,3
                  DR(I) = -FAC*S(I,3)
   40          continue
            else
               DO 50 I=1,3
                  DR(I) = +FAC*S(I,2)
   50          continue
            endif
C
            DPHI(1) = R(2)*DR(3) + DR(2)*R(3)
            DPHI(2) = R(3)*DR(1) + DR(3)*R(1)
            DPHI(3) = R(1)*DR(2) + DR(1)*R(2)
C
            DA = R(M)*DR(M)
            DB = (1.D0/3.D0)*DR(M)
            DC = DPHI(M) + (5.D0/3.D0)*DA
            DRHO(M) = R(M)*DC + DR(M)*C - DA
            DRHO(MP1) = A*(DR(MM1) - DB) + DA*(R(MM1) - B)
            DRHO(MM1) = A*(DR(MP1) - DB) + DA*(R(MP1) - B)
C
            SUM = 0.0d0
            DO 60 I=1,3
               IP1=ADD1(I)
               IM1=SUB1(I)
               DGTILD(I)  =(R(IP1)-R(IM1))*DPHI(I)
     *                  +(DR(IP1) - DR(IM1))*PHI(I)
     *                  +S(I,9)*DRHO(I) - DRHO(IP1) + DRHO(IM1)
               SUM = SUM +S(I,7)*(DGTILD(I)+DPHI(I))
     *                +S(I,8)*(DGTILD(I)-DPHI(I))
   60       continue
            SUM = 0.5D0 * SUM
            DO 70 I=1,3
               IP1=ADD1(I)
               IM1=SUB1(I)
               SUM = SUM + S(I,4)*(DR(I) + DGTILD(IM1) - DGTILD(IP1))
   70       continue
            DZOUT(J) = SUM
  100    continue
      END IF
      RETURN
      END


! R help recommended that subroutines should not have underscores in the names
! compile fortran code for use with R: R CMD SHLIB stochastic-logistic-subroutines.f90

! https://masuday.github.io/fortran_tutorial/random.html
subroutine rstduniform(u)
  implicit none
  double precision,intent(out) :: u
  double precision :: r
  call random_number(r)
  u = 1 - r
end subroutine rstduniform

! modified from https://masuday.github.io/fortran_tutorial/random.html
! based on https://www.cse.wustl.edu/~jain/books/ftp/ch5f_slides.pdf
subroutine rnormal(mu, sigma, x)
  implicit none
  double precision,intent(in) :: mu, sigma
  double precision,intent(out) :: x
  double precision,parameter :: pi=3.14159265
  double precision :: u1,u2
  call rstduniform(u1)
  call rstduniform(u2)
  x = mu + sigma * cos(2 * pi * u1) * sqrt(-2 * log(u2))
end subroutine rnormal

! rnorm is used to test rnormal from R; not used in logmodf
subroutine rnorm(reps, mu, sigma, arr)
  implicit none
  integer :: i
  integer, intent(in) :: reps
  double precision, intent(in) :: mu, sigma
  double precision, intent(inout) :: arr(reps)
  do i=1,reps
    call rnormal(mu, sigma, arr(i))
  end do
end subroutine rnorm

subroutine logmodf(t, yinit, r, k, thetasd, y)
  implicit none
  integer :: i
  integer, intent(in) :: t
  double precision, intent(in) :: yinit, r, k, thetasd
  double precision :: mu, theta
  double precision, intent(inout) :: y(t)
  mu = 0.0
  y(1) = yinit
  do i=2,t
    call rnormal(mu, thetasd, theta)
    y(i) = y(i-1) * (r - r * (y(i-1) / k)) * exp(theta)
  end do
end subroutine logmodf


! $UWHPSC/codes/adaptive_quadrature/openmp2/adapquad_mod.f90

module adapquad_mod

    use omp_lib
    implicit none
    integer :: nthreads
    integer, parameter :: maxlevel = 30
    save

contains

recursive subroutine adapquad(f,a,b,tol,intest,errest,level,fa,fb)
    implicit none
    real(kind=8), intent(in) :: a,b,tol
    real(kind=8), intent(out) :: intest
    real(kind=8), optional, intent(out) :: errest
    integer, optional, intent(in) :: level
    real(kind=8), optional, intent(in) :: fa,fb
    real(kind=8), external :: f

    ! local variables:
    real(kind=8) :: xmid, fmid, trapezoid, simpson, errest1, errest2, &
                    intest1, intest2, tol2, f_a, f_b
    integer :: thislevel, nextlevel, thread_num

    ! Unit 7 should be opened for writing out quadrature points in
    ! the main program.  Use this format statement for writes below:
701 format(2e20.10)

    ! Unit 8 should be opened for writing out intervals, level, thread_num in
    ! the main program.  Use this format statement for writes below:
801 format(2e20.10,i3,i3)

    if (.not. present(level)) then
        ! called from main program, which is level=1:
        thislevel = 1
    else
        thislevel = level
    endif

    thread_num = 0  ! for serial execution
    !$ thread_num = omp_get_thread_num()

    write(8,801) a,b,thislevel,thread_num

    !print 601, a, b, thislevel
601 format('+++ adapquad called with a = ',e13.6,'  b = ',e13.6, ' level = ',i3)

    if (present(fa)) then
        f_a = fa
    else
        f_a = f(a)
        write(7,701) a, f_a
    endif
    if (present(fb)) then
        f_b = fb
    else
        f_b = f(b)
        write(7,701) b, f_b
    endif

    trapezoid = 0.5d0*(b-a)*(f_a + f_b)

    xmid = 0.5d0*(a + b)
    fmid = f(xmid)

    ! write function value for plotting:
    write(7,701) xmid, fmid

    ! print to screen for debugging:
    !print *, '+++ Level = ',thislevel, '  xmid = ',xmid

    simpson = (b-a)*(f_a + 4.d0*fmid + f_b) / 6.d0

    errest = abs(trapezoid - simpson)

    !print 602, errest
602 format('+++   error estimate: ',e13.6)

    if ((errest > tol) .and. (thislevel < maxlevel)) then
        ! recursively apply this subroutine to each half, with
        ! tolerance tol/2 for each, and nextlevel = thislevel+1:
        tol2 = tol / 2.d0
        nextlevel = thislevel + 1

        !$omp parallel sections
        !$omp section
            call adapquad(f,a,xmid,tol2,intest1,errest1,nextlevel,f_a,fmid)

        !$omp section
            call adapquad(f,xmid,b,tol2,intest2,errest2,nextlevel,fmid,f_b)
        !$omp end parallel sections

        intest = intest1 + intest2
        errest = errest1 + errest2
    else
        ! Use the trapezoid approximation.
        ! Note that simpson would be better,
        ! but we have error estimate for trapezoid
        intest = trapezoid
    endif

end subroutine adapquad

end module adapquad_mod


	DOUBLE PRECISION FUNCTION R3(X)
	IMPLICIT NONE
	DOUBLE PRECISION X,P(0:4),Q(0:4),NUMER,DENOM
        INTEGER J
	DATA P/-2.9961 0707 7035 4217 4D-3,
     .         -4.9473 0910 6232 5073 4D-2,
     .         -2.2695 6593 5396 8693 0D-1,
     .         -2.7866 1308 6096 4778 8D-1,
     .         -2.2319 2459 7341 8468 6D-2/
	DATA Q/ 1.0620 9230 5284 6791 8D-2,
     .          1.9130 8926 1078 2984 1D-1,
     .          1.0516 7510 7067 9320 7,
     .          1.9873 3201 8171 3525 6,
     .          1.0000 0000 0000 0000 0/
      NUMER = 0
      DENOM = 0
	DO 10 J=0,4
	    NUMER=NUMER +P(J)*X**(-2*J)
          DENOM=DENOM + Q(J)*X**(-2**J)
10	CONTINUE
      R3= NUMER/DENOM
	RETURN
	END


      SUBROUTINE TOPCENXYZ(GLAT,GLONG,HEIGHT,RADEQTR,FLAT,XYZ)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C FOR AN ELLIPSOID OF REVOLUTION, DO THE FOLLOWING --
C
C    GIVEN: 1. A POINT OF INTEREST LYING A KNOWN DISTANCE ABOVE/BELOW A
C                 POINT ON THE ELLIPSOID. THE POINT ON THE ELLIPSOID HAS
C                 KNOWN GEODETIC LATITUDE AND LONGITUDE;
C           2. ELLIPSOID RADIUS AT THE EQUATOR;
C           3. FLATTENING COEFFICIENT OF THE ELLIPSOID;
C
C    FIND:  THE CARTESIAN COORDINATES OF THE POINT.
C
C           THE AXES TO WHICH THESE COORDINATES ARE REFERENCED HAVE
C           THEIR ORIGIN AT THE ELLIPSOID'S ORIGIN, THE XY PLANE
C           COINCIDENT WITH THE ELLIPSOID EQUATOR, THE Z AXIS AS THE
C           ELLIPSOID AXIS OF REVOLUTION(IE, THE AXIS ABOUT AN ELLIPSE
C           WAS ROTATED TO PRODUCE THE ELLIPSOID). POSITIVE LATITUDE IS
C           MEASURED TOWARD +Z AND POSITIVE LONGITUDE IS MEASURED FROM
C           THE XZ PLANE TOWARD THE YZ PLANE.
C
C
C VARIABLE DIM TYPE I/O DESCRIPTION
C -------- --- ---- --- -----------
C
C GLAT      1  R*8   I  THE GEODETIC LATITUDE OF A POINT ON THE
C                       SURFACE BELOW THE POINT OF INTEREST. IN RADIANS.
C
C                       A LINE FROM THE POINT OF INTEREST TO THE
C                       SURFACE IS NORMAL TO THE SURFACE AT LATITUDE
C                       GLAT.
C
C                       GEODETIC LATITUDE IS THE ANGLE BETWEEN A LINE
C                       NORMAL TO THE LOCAL HORIZON AND THE EQUATOR.
C                       GEODETIC LATITUDE INVOLVES FLATTENING.
C
C GLONG     1  R*8   I  THE LONGITUDE OF THE POINT OF INTEREST.
C                       IN RADIANS.
C
C HEIGHT    1  R*8   I  THE HEIGHT OF THE POINT OF INTEREST ABOVE THE
C                       ELLIPSOID. MEASURED NORMAL TO THE LOCAL HORIZON.
C                       ANY LENGTH UNIT MAY BE USED.
C
C RADEQTR   1  R*8   I  THE RADIUS AT THE EQUATOR OF THE ELLIPSOID.
C                       HEIGHT AND RADEQTR MUST HAVE THE SAME LENGTH
C                       UNIT.
C
C                       THE EQUATOR LIES IN THE 'FAT' PART OF THE
C                       ELLIPSOID, NORMAL TO THE AXIS OF REVOLUTION.
C
C                       IF RADEQTR IS ZERO OR NEGATIVE, EARTH RADIUS IN
C                       KILOMETERS IS USED.
C
C FLAT      1  R*8   I  THE FLATTENING COEFFICIENT. UNITLESS.
C
C                       SPHERE HAS FLAT=0.0
C
C                       IF FLAT < 0.0 IS ENTERED, OBLATE EARTH IS USED
C                       AS DEFINED BY CONST(59). CONST IS A FUNCTION
C                       SUBROUTINE.
C
C XYZ       3  R*8   O  THE CARTESIAN COORDINATES OF THE POINT.
C                       UNITS ARE THE SAME AS FOR RADEQTR AND HEIGHT.
C
C***********************************************************************
C
C BY C PETRUZZO, 10/83.
C
C***********************************************************************
C
C  EQUATIONS ARE FROM THE BOOK: METHODS OF ORBIT DETERMINATION, BY
C  P.R. ESCOBAL, 1983 REPRINT(WITH CORRECTIONS) OF 1965 EDITION,
C  PAGES 399 AND 400.
C
C
      REAL*8 XYZ(3)
      INTEGER INIT/1/
      REAL*8 HALFPI/ 1.570796326794897D0 /
      REAL*8 DEGRAD/ 57.29577951308232D0 /
      LOGICAL SPHERE
C
      IBUG=0
      LUBUG=19
C
      IF(INIT.EQ.1) THEN
        INIT=0
        POLE = HALFPI - 1.D-3/DEGRAD
        REARTH = CONST(53)
        FLATCONST = CONST(59)
        END IF
C
      IF(IBUG.NE.0) WRITE(LUBUG,9001) GLAT*DEGRAD,GLONG*DEGRAD,HEIGHT,
     *     RADEQTR,FLAT
 9001 FORMAT(' TOPCENXYZ DEBUG.'/,
     *       '    GLAT=',G16.8,'  GLONG=',G16.8,'  HEIGHT=',G16.8/,
     *       '    RADEQTR=',G16.8,'  FLAT=',G16.8)
C
C  SET INTERNAL VARIABLE CONTAINING THE FLATTENING COEFFICIENT.
      IF(FLAT.LT.0.D0) THEN
        FL=FLATCONST
      ELSE
        FL=FLAT
        END IF
      SPHERE = FL.EQ.0.D0
C
C  SET THE INTERNAL VARIABLES CONTAINING LATITUDES.
C  GDLAT IS GEODETIC, GCLAT IS GEOCENTRIC.
      GDLAT=GLAT
      IF(SPHERE) THEN
        GCLAT=GLAT
      ELSE
        IF(DABS(GLAT).LT.POLE) THEN
          GCLAT=DATAN( (1.D0-FL)**2 * DTAN(GLAT) )
        ELSE
          GCLAT=GLAT
          END IF
        END IF
C
C  GET RC, THE RADIUS FROM THE ORIGIN OF THE ELLIPSOID TO THE
C  SURFACE POINT BELOW THE POINT OF INTEREST.
      AE=RADEQTR
      IF(SPHERE) THEN
        RC=AE
      ELSE
        TEMP=(2.D0 - FL) * FL
        RC = AE * DSQRT( (1.D0-TEMP)/(1.D0-TEMP*( DCOS(GCLAT)**2) ))
        END IF
C
      IF(IBUG.NE.0) WRITE(LUBUG,9002) GDLAT*DEGRAD,GCLAT*DEGRAD,RC
 9002 FORMAT(' TOPCENXYZ DEBUG.'/,
     *       '    GDLAT=',G16.8,'  GCLAT=',G16.8,'  RC=',G16.8)
C
C  GET R, THE RADIUS FROM THE ORIGIN TO THE POINT OF INTEREST.
      HS=HEIGHT
      IF(SPHERE) THEN
        TEMP=1.D0
      ELSE
        TEMP=DCOS(GDLAT-GCLAT)
        END IF
      IF(HS.NE.0.D0) THEN
        R = DSQRT( RC**2 + HS**2 + 2.D0*RC*HS*TEMP )
      ELSE
        R = RC
        END IF
C
C  GET DELGCLAT, THE DIFFERENCE BETWEEN THE GEOCENTRIC LATITUDE OF THE
C  POINT OF INTEREST AND THE GEOCENTRIC LATITUDE OF THE SURFACE POINT
C  BELOW THE POINT OF INTEREST.
      IF(SPHERE) THEN
        DELGCLAT = 0.D0
      ELSE
        DELGCLAT = DASIN( HS/R * DSIN(GDLAT-GCLAT) )
        END IF
C
C  GET SIN/COSINES NEEDED BELOW.
      THETA = GLONG
      DELTA = GCLAT + DELGCLAT
      COSDELTA = DCOS(DELTA)
      SINDELTA = DSIN(DELTA)
      COSTHETA = DCOS(THETA)
      SINTHETA = DSIN(THETA)
C
      IF(IBUG.NE.0) WRITE(LUBUG,9003) THETA*DEGRAD,DELTA*DEGRAD,R
 9003 FORMAT(' TOPCENXYZ DEBUG.'/,
     *       '    THETA=',G16.8,'  DELTA=',G16.8,'  R=',G16.8)
C
C  COMPUTE CARTESIAN POSITIONS
      XYZ(1) = R * COSDELTA * COSTHETA
      XYZ(2) = R * COSDELTA * SINTHETA
      XYZ(3) = R * SINDELTA
C
      IF(IBUG.NE.0) WRITE(LUBUG,9004) XYZ
 9004 FORMAT(' TOPCENXYZ DEBUG. XYZ=',3G16.8)
C
      RETURN
      END


! PR middle-end/82004
! { dg-do run }
! { dg-options "-Ofast" }

  integer, parameter :: r8 = selected_real_kind(13), i4 = kind(1)
  integer (i4), parameter :: a = 400, b = 2
  real (r8), parameter, dimension(b) :: c = (/ .001_r8, 10.00_r8 /)
  real (r8) :: d, e, f, g, h
  real (r8), parameter :: j &
    = 10**(log10(c(1))-(log10(c(b))-log10(c(1)))/real(a))

  d = c(1)
  e = c(b)
  f = (log10(e)-log10(d))/real(a)
  g = log10(d) - f
  h = 10**(g)
  if (h.ne.j) stop 1
end


c-----------------------------------------------------------------------------
c     Computes Sum(i=1,n) x(i)*H_i(t) where the H_i are Hicks-Henne
c     functions
c-----------------------------------------------------------------------------
      real function hickshenne(n, x, t)
      implicit none
      integer n
      real    x(*), t

      integer i
      real    h, HicksHenneFunc

      h = 0.0
      do i=1,n
         h = h + x(i)*HicksHenneFunc(n, i, t)
      enddo

      HicksHenne = h

      return
      end

c-----------------------------------------------------------------------------
c     Compute i'th HicksHenne function
c-----------------------------------------------------------------------------
      real function HicksHenneFunc(n, i, t)
      implicit none
      integer n, i
      real    t

      real    xh, tmp1, tmp2, tmp3, tmp4, PI

      PI   = 4.0*atan(1.0)
      xh   = real(i)/(n+4.0)
      tmp1 = log(0.5)/log(xh)
      tmp2 = PI*t**tmp1
      tmp3 = sin(tmp2)
      tmp4 = tmp3**3

      HicksHenneFunc = tmp4

      return
      end


module plane42

    !! This module contains subroutines specific to the plane42 element
    !!
    !! The plane42 element has 4 nodes. Each node has 2 degrees-of-freedom,
    !! namely, displacement along the \(x\)- and \(y\)-coordinate directions.
    !!
    !! The nodes are numbered counter-clockwise as indicated below. The
    !! figure also shows how the element edges are labelled. For example,
    !! edge 1 is the edge between element node 1 and 2.
    !!
    !!       N4    E3    N3
    !!          o------o
    !!          |      |
    !!       E4 |      | E2
    !!          |      |
    !!          o------o
    !!       N1    E1    N2
    !!
    !!
    !! `N1` = element node 1, `N2` = element node 2, etc
    !! `E1` = element face 1, `E2` = element face 2, etc

    use types
    implicit none
    save

    private
    public :: plane42_N, plane42_shape, plane42_me, plane42_ke, plane42_re, plane42_ss, plane42_lme, plane42_cebc
contains

	subroutine plane42_N(xi, eta, N)
        !! This subroutine calculates N for one gauss point in a plane42 element

        use fedata

        real(wp), intent(in) :: xi, eta
        real(wp), intent(out) :: N(2,8)
        real(wp) :: L(3,4)
        integer :: i

        ! Calculate L
        L = 0
        L(1,1) = 1
        L(2,4) = 1
        L(3,2) = 1
        L(3,3) = 1

        ! Calculate N
        N = 0.0_wp
        N(1,1) = 0.25_wp*(1-eta)*(1-xi)
        N(2,2) = 0.25_wp*(1-eta)*(1-xi)
        N(1,3) = 0.25_wp*(1+eta)*(1-xi)
        N(2,4) = 0.25_wp*(1+eta)*(1-xi)
        N(1,5) = 0.25_wp*(1+eta)*(1+xi)
        N(2,6) = 0.25_wp*(1+eta)*(1+xi)
        N(1,7) = 0.25_wp*(1-eta)*(1+xi)
        N(2,8) = 0.25_wp*(1-eta)*(1+xi)

    end subroutine plane42_N

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

	subroutine plane42_shape(xi, eta, N, B, det_J, xe)
        !! This subroutine calculates N, B, Gamma and |J| for one gauss point
        !! in a plane42 element

        use fedata

		real(wp), dimension(:), intent(in) :: xe
            !! Nodal coordinates of this element in undeformed configuration
            !!
            !! * `xe(1:2)` = \((x,y)\)-coordinates of element node 1
            !! * `xe(3:4)` = \((x,y)\)-coordinates of element node 1
            !! * `xe(5:6)` = \((x,y)\)-coordinates of element node 2
            !! * `xe(7:8)` = \((x,y)\)-coordinates of element node 2
            !!
            !! See also [[plane42]]
        real(wp), intent(in) :: xi, eta
        	!! coordinates for gauss point
        real(wp), intent(out) :: B(3,8), det_J, N(2,8)
			!!
        real(wp) :: L(3,4), Gamma(2,2), Gammatilde(4,4), Ntilde(4,8)
        	!!
        real(wp) :: N1dxi,N2dxi,N3dxi,N4dxi, &
        			N1deta,N2deta,N3deta,N4deta
        real(wp) :: J11, J12, J21, J22

        integer :: i

        ! Calculate L
        L = 0
        L(1,1) = 1
        L(2,4) = 1
        L(3,2) = 1
        L(3,3) = 1

        ! Calculate N
        N = 0.0_wp
        N(1,1) = 0.25_wp*(1-eta)*(1-xi)
        N(2,2) = 0.25_wp*(1-eta)*(1-xi)
        N(1,3) = 0.25_wp*(1+eta)*(1-xi)
        N(2,4) = 0.25_wp*(1+eta)*(1-xi)
        N(1,5) = 0.25_wp*(1+eta)*(1+xi)
        N(2,6) = 0.25_wp*(1+eta)*(1+xi)
        N(1,7) = 0.25_wp*(1-eta)*(1+xi)
        N(2,8) = 0.25_wp*(1-eta)*(1+xi)

        ! Calculate Ntilde
		N1dxi = -0.25_wp+0.25_wp*eta
        N1deta = -0.25_wp+0.25_wp*xi
        N2dxi =  0.25_wp-0.25_wp*eta
        N2deta = -0.25_wp-0.25_wp*xi
        N3dxi =  0.25_wp+0.25_wp*eta
        N3deta =  0.25_wp+0.25_wp*xi
        N4dxi = -0.25_wp-0.25_wp*eta
        N4deta =  0.25_wp-0.25_wp*xi

        Ntilde = 0
        Ntilde(1,1) = N1dxi
        Ntilde(2,1) = N1deta
        Ntilde(3,2) = N1dxi
        Ntilde(4,2) = N1deta

        Ntilde(1,3) = N2dxi
        Ntilde(2,3) = N2deta
        Ntilde(3,4) = N2dxi
        Ntilde(4,4) = N2deta

        Ntilde(1,5) = N3dxi
        Ntilde(2,5) = N3deta
        Ntilde(3,6) = N3dxi
        Ntilde(4,6) = N3deta

        Ntilde(1,7) = N4dxi
        Ntilde(2,7) = N4deta
        Ntilde(3,8) = N4dxi
        Ntilde(4,8) = N4deta

        ! Calculate J and |J|
        J11 = dot_product(Ntilde(1,:),xe)
        J21 = dot_product(Ntilde(2,:),xe)
        J12 = dot_product(Ntilde(3,:),xe)
        J22 = dot_product(Ntilde(4,:),xe)
        det_J = J11*J22-J12*J21
!$$$$$$         print *, '----------------------------------'
!$$$$$$         print *, 'J:'
!$$$$$$         print '(24(f4.2,tr1))', J11,J12
!$$$$$$         print '(24(f4.2,tr1))', J21,J22
!$$$$$$         print *, 'det_J',det_J

        ! Calculate Gammatilde
        Gamma = 0
        Gamma(1,1) = 1/det_J*J22
        Gamma(1,2) = 1/det_J*(-J12)
        Gamma(2,1) = 1/det_J*(-J21)
        Gamma(2,2) = 1/det_J*J11

        Gammatilde = 0
        Gammatilde(1,1) = Gamma(1,1)
        Gammatilde(1,2) = Gamma(1,2)
        Gammatilde(2,1) = Gamma(2,1)
        Gammatilde(2,2) = Gamma(2,2)
        Gammatilde(3,3) = Gamma(1,1)
        Gammatilde(3,4) = Gamma(1,2)
        Gammatilde(4,3) = Gamma(2,1)
        Gammatilde(4,4) = Gamma(2,2)
!PRINT
!$$$$$$         print *, 'Gammatilde:'
!$$$$$$         do i = 1,4
!$$$$$$             print "(24(f4.2,tr1))",Gammatilde(i,:)
!$$$$$$         end do

        ! Calculate B
		B = matmul(matmul(L,Gammatilde),Ntilde)
!PRINT
!$$$$$$         print *, 'B',shape(B)
!$$$$$$         do i = 1,4
!$$$$$$             print "(24(f4.2,tr1))",B(i,:)
!$$$$$$         end do

    end subroutine plane42_shape

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

    subroutine plane42_lme(xe, thk, dens, me)

        !! This subroutine constructs the mass matrix for
        !! a rectangular 4-noded quad element.

        use fedata

        real(wp), intent(in) :: thk, dens
        real(wp), dimension(:), intent(in) :: xe
        real(wp), dimension(:), intent(out) :: me
        integer :: i, j, ike
		real(wp) :: loc(3), w(3), xi, eta
        real(wp) :: NtN(8), N(2,8), det_J, A
        real(wp) :: Ntilde(4,8)
        real(wp) :: N1dxi,N2dxi,N3dxi,N4dxi, &
        			N1deta,N2deta,N3deta,N4deta
        real(wp) :: J11, J12, J21, J22

		! Reset variables
		loc = 0
        w = 0
        me = 0

		! Define variable Gauss points and weighting
        select case (no_gauss_points_k)
            case (1)
            	loc(1) = 0
                w(1) = 2
            case(2)
                loc(1) = 1_wp/sqrt(3.0_wp)
                loc(2) = -1_wp/sqrt(3.0_wp)
                w(1) = 1
                w(2) = 1
            case(3)
            	loc(1) = sqrt(0.6_wp)
                loc(2) = 0
                loc(3) = -sqrt(0.6_wp)
                w(1) = 5.0_wp/9.0_wp
                w(2) = 8.0_wp/9.0_wp
                w(3) = -w(1)
            end select

        ! Calculate me for each gauss point
        do i = 1, no_gauss_points_k
            do j = 1, no_gauss_points_k
                xi = loc(i)
                eta = loc(j)

                ! Calculate N^T*N
                NtN = 0.0_wp
                NtN(1) = (0.25_wp*(1-eta)*(1-xi))**2
                NtN(2) = (0.25_wp*(1-eta)*(1-xi))**2
                NtN(3) = (0.25_wp*(1+eta)*(1-xi))**2
                NtN(4) = (0.25_wp*(1+eta)*(1-xi))**2
                NtN(5) = (0.25_wp*(1+eta)*(1+xi))**2
                NtN(6) = (0.25_wp*(1+eta)*(1+xi))**2
                NtN(7) = (0.25_wp*(1-eta)*(1+xi))**2
                NtN(8) = (0.25_wp*(1-eta)*(1+xi))**2
        		! Sum Numerical integration of me

                ! Calculate Ntilde
                N1dxi = -0.25_wp+0.25_wp*eta
                N1deta = -0.25_wp+0.25_wp*xi
                N2dxi =  0.25_wp-0.25_wp*eta
                N2deta = -0.25_wp-0.25_wp*xi
                N3dxi =  0.25_wp+0.25_wp*eta
                N3deta =  0.25_wp+0.25_wp*xi
                N4dxi = -0.25_wp-0.25_wp*eta
                N4deta =  0.25_wp-0.25_wp*xi

                Ntilde = 0
                Ntilde(1,1) = N1dxi
                Ntilde(2,1) = N1deta
                Ntilde(3,2) = N1dxi
                Ntilde(4,2) = N1deta

                Ntilde(1,3) = N2dxi
                Ntilde(2,3) = N2deta
                Ntilde(3,4) = N2dxi
                Ntilde(4,4) = N2deta

                Ntilde(1,5) = N3dxi
                Ntilde(2,5) = N3deta
                Ntilde(3,6) = N3dxi
                Ntilde(4,6) = N3deta

                Ntilde(1,7) = N4dxi
                Ntilde(2,7) = N4deta
                Ntilde(3,8) = N4dxi
                Ntilde(4,8) = N4deta

                ! Calculate J and |J|
                J11 = dot_product(Ntilde(1,:),xe)
                J21 = dot_product(Ntilde(2,:),xe)
                J12 = dot_product(Ntilde(3,:),xe)
                J22 = dot_product(Ntilde(4,:),xe)
                det_J = J11*J22-J12*J21
                me = me + w(i)*w(j)*thk*dens*NtN*det_J
        	end do
        end do
        ! Scale lumped mass matrix to correct mass
        A = det_J*4

        me = me * dens*thk*A/sum(me)

    end subroutine plane42_lme

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

    subroutine plane42_me(xe, thk, dens, me)

        !! This subroutine constructs the mass matrix for
        !! a rectangular 4-noded quad element.

        use fedata

        real(wp), intent(in) :: thk
            !! Thickness of this element
        real(wp), intent(in) :: dens
            !! Density of this element
        real(wp), dimension(:), intent(in) :: xe
            !! Nodal coordinates of this element in undeformed configuration
            !!
            !! * `xe(1:2)` = \((x,y)\)-coordinates of element node 1
            !! * `xe(3:4)` = \((x,y)\)-coordinates of element node 1
            !! * `xe(5:6)` = \((x,y)\)-coordinates of element node 2
            !! * `xe(7:8)` = \((x,y)\)-coordinates of element node 2
            !!
            !! See also [[plane42]]
        real(wp), dimension(:,:), intent(out) :: me
            !! Stiffness matrix
        integer :: i, j, ike
		real(wp) :: loc(3), w(3), xi, eta
        	!! Gauss numerical integration
        real(wp), dimension(3, mdim) :: B
        real(wp) :: det_J
        real(wp) :: N(2,8)
        	!! Outputs of shape subroutime

		! Reset variables
		loc = 0
        w = 0
        me = 0

		! Define variable Gauss points and weighting
        select case (no_gauss_points_k)
            case (1)
            	loc(1) = 0
                w(1) = 2
            case(2)
                loc(1) = 1_wp/sqrt(3.0_wp)
                loc(2) = -1_wp/sqrt(3.0_wp)
                w(1) = 1
                w(2) = 1
            case(3)
            	loc(1) = sqrt(0.6_wp)
                loc(2) = 0
                loc(3) = -sqrt(0.6_wp)
                w(1) = 5.0_wp/9.0_wp
                w(2) = 8.0_wp/9.0_wp
                w(3) = -w(1)
            end select

        ! Calculate me for each gauss point
        do i = 1, no_gauss_points_k
            do j = 1, no_gauss_points_k
                xi = loc(i)
                eta = loc(j)
                ! Calculate N, B and detJ with shape subroutine
				call plane42_shape(xi, eta, N, B, det_J, xe)
        		! Sum Numerical integration of me
                me = me + w(i)*w(j)*thk*dens*matmul(transpose(N),N)*det_J
        	end do
        end do
    end subroutine plane42_me

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

    subroutine plane42_ke(xe, young, nu, thk, ke)

        !! This subroutine constructs the stiffness matrix for
        !! a rectangular 4-noded quad element.

        use fedata

        real(wp), intent(in) :: young
            !! Young's Modulus for this element
        real(wp), intent(in) :: nu
            !! Poisson's Ratio for this element
        real(wp), intent(in) :: thk
            !! Thickness of this element
        real(wp), dimension(:), intent(in) :: xe
            !! Nodal coordinates of this element in undeformed configuration
            !!
            !! * `xe(1:2)` = \((x,y)\)-coordinates of element node 1
            !! * `xe(3:4)` = \((x,y)\)-coordinates of element node 1
            !! * `xe(5:6)` = \((x,y)\)-coordinates of element node 2
            !! * `xe(7:8)` = \((x,y)\)-coordinates of element node 2
            !!
            !! See also [[plane42]]
        real(wp), dimension(:,:), intent(out) :: ke
            !! Stiffness matrix
        real(wp) :: cmat(3,3), fact
			!! C, constitutive matrix
        integer :: i, j, ike
		real(wp) :: loc(3), w(3), xi, eta
        	!! Gauss numerical integration
        real(wp), dimension(3, mdim) :: B
        real(wp) :: det_J
        real(wp) :: N(2,8)
        	!! Outputs of shape subroutime

		! Reset variables
		loc = 0
        w = 0
        ke = 0

		! Define variable Gauss points and weighting
        select case (no_gauss_points_k)
            case (1)
            	loc(1) = 0
                w(1) = 2
            case(2)
                loc(1) = 1_wp/sqrt(3.0_wp)
                loc(2) = -1_wp/sqrt(3.0_wp)
                w(1) = 1
                w(2) = 1
            case(3)
            	loc(1) = sqrt(0.6_wp)
                loc(2) = 0
                loc(3) = -sqrt(0.6_wp)
                w(1) = 5.0_wp/9.0_wp
                w(2) = 8.0_wp/9.0_wp
                w(3) = -w(1)
            end select

        ! build constitutive matrix (plane stress)
        cmat = 0
        fact = young/(1-nu**2)
        cmat(1,1) = fact
        cmat(1,2) = fact*nu
        cmat(2,1) = fact*nu
        cmat(2,2) = fact
        cmat(3,3) = fact*(1-nu)/2

        ! Calculate ke for each gauss point
        do i = 1, no_gauss_points_k
            do j = 1, no_gauss_points_k
                xi = loc(i)
                eta = loc(j)
                ! Calculate N, B and detJ with shape subroutine
				call plane42_shape(xi, eta, N, B, det_J, xe)
        		! Calculate K
                ke = ke + w(i)*w(j)*thk*matmul(matmul(transpose(B),cmat),B)*det_J
        	end do
        end do
!PRINT
!$$$$$$         print *, 'ke:'
!$$$$$$         do ike = 1,8
!$$$$$$             print "(24(f4.2,tr1))",ke(ike,:)
!$$$$$$         end do

    end subroutine plane42_ke
!
!--------------------------------------------------------------------------------------------------
!
    subroutine plane42_re(xe, eface, fe, thk, re)

        !! This subroutine computes the element load vector due
        !! to surface traction (traction is always perpendicular
        !! to element face).

        ! inputs:
        ! xe		nodal coordniates
        ! eface		face number
        ! fe		pressure value
        ! thk		thickness
        ! re		element load vector (output)

        integer, intent(in) :: eface
            !! Element face where traction (pressure) is applied

        real(wp), intent(in) :: fe
            !! Value of surface traction (pressure)
        real(wp), intent(in) :: thk
            !! Thickness of this element
        real(wp), dimension(:), intent(in) :: xe
            !! Nodal coordinates of this element in undeformed configuration (see also [[plane42_ke]])
        real(wp), intent(out) :: re(8)
            !! Element force vector
            !!
            !! * `re(1:2)` = \((f_x^1, f_y^1)\) force at element node 1 in \(x\)- and y-direction
            !! * `re(3:4)` = \((f_x^2, f_y^2)\) force at element node 1 in \(x\)- and y-direction
            !! * etc...
        real(wp) :: aa, bb, nface(2,8), f(2)

        aa = (xe(3)-xe(1))/2
        bb = (xe(8)-xe(2))/2

        nface = 0
        f = 0
        if (eface == 1) then
            nface(1,1) = aa
            nface(1,3) = aa
            nface(2,2) = aa
            nface(2,4) = aa
            f(2) = fe
        elseif (eface == 2) then
            nface(1,3) = bb
            nface(1,5) = bb
            nface(2,4) = bb
            nface(2,6) = bb
            f(1) = -fe
        elseif (eface == 3) then
            nface(1,5) = aa
            nface(1,7) = aa
            nface(2,6) = aa
            nface(2,8) = aa
            f(2) = -fe
        elseif (eface == 4) then
            nface(1,1) = bb
            nface(1,7) = bb
            nface(2,2) = bb
            nface(2,8) = bb
            f(1) = fe
        endif

        re = matmul(transpose(nface), f) * thk

    end subroutine plane42_re
!
!--------------------------------------------------------------------------------------------------
!
    subroutine plane42_cebc(e, cebc)

        !! This subroutine computes the element damping vector due
        !! to absorbing BCs (modeled in flextract as surface tractions)
        !! (traction is always perpendicular to element face).

        use fedata
        use fortranhacks

        integer, intent(in) :: e
        real(wp), intent(out) :: cebc(8,8)
        integer :: plane_stress_or_strain, eface, n, i, nen
        real(wp) :: thk, young, nu, dens
        real(wp) :: xe(mdim), z(2,2), aa, bb, nface(2,8), cp, cs, surface_normal(2,2), vector_normal(2), ident(2,2)

        plane_stress_or_strain = 1
        !! Choose either 1 for plane_stress or 2 for plane_strain

        cebc = 0

        ! loop over all surface loads
        do i = 1, np
          	! if load i is on element e
            if ((loads(i,2) == e) .and. (loads(i,1)==2)) then

				! Load material properties
                thk = mprop(element(e)%mat)%thk
        		young = mprop(element(e)%mat)%young
        		nu = mprop(element(e)%mat)%nu
        		dens = mprop(element(e)%mat)%dens

                ! Find coordinates
                nen = element(e)%numnode
                do n = 1, nen
                     xe(2*n-1) = x(element(e)%ix(n),1)
                     xe(2*n  ) = x(element(e)%ix(n),2)
                end do

                ! Find face that the BC is applied to
                eface = loads(i,3)

				! Find surface dimensions
                aa = (xe(3)-xe(1))/2
                bb = (xe(8)-xe(2))/2

                nface = 0
                vector_normal = 0
                if (eface == 1) then
                    nface(1,1) = aa
                    nface(1,3) = aa
                    nface(2,2) = aa
                    nface(2,4) = aa
					vector_normal(2) = -1
                elseif (eface == 2) then
                    nface(1,3) = bb
                    nface(1,5) = bb
                    nface(2,4) = bb
                    nface(2,6) = bb
                    vector_normal(1) = 1
                elseif (eface == 3) then
                    nface(1,5) = aa
                    nface(1,7) = aa
                    nface(2,6) = aa
                    nface(2,8) = aa
                    vector_normal(2) = 1
                elseif (eface == 4) then
                    nface(1,1) = bb
                    nface(1,7) = bb
                    nface(2,2) = bb
                    nface(2,8) = bb
                    vector_normal(1) = -1
                endif
				surface_normal(1,1) = vector_normal(1)**2
                surface_normal(1,2) = vector_normal(1)*vector_normal(2)
                surface_normal(2,1) = vector_normal(1)*vector_normal(2)
                surface_normal(2,2) = vector_normal(2)**2

				! Calculate damping coefficients
                cs = sqrt(young/(2*(1+nu)*dens))
                select case (plane_stress_or_strain)
                    case (1)
                        ! case of plane stress
                        cp = sqrt(young/((1-nu**2)*dens))
                    case (2)
                        !case of plane strain
                        cp = sqrt(young*(1-nu)/((1+nu)*(1-2*nu)*dens))
                end select

				! Build identity matrix
                call identity(ident)

                ! Build z damping matrix
                z = dens*cp*surface_normal + dens*cs*(ident-surface_normal)*loads(i,4) !damping scales with set pressure

                ! Build element damping matrix for BCs
                cebc = cebc + matmul(matmul(transpose(nface), z),nface) * thk

            end if
        end do

    end subroutine plane42_cebc
!
!--------------------------------------------------------------------------------------------------
!
    subroutine plane42_ss(xe, de, young, nu, estress, estrain)

        !! This subrotuine computes the element stress and strain (The location inside the element
        !! where stress and and strain is evaluated, is defined inside the subroutine).

        use fedata

        real(wp), intent(in) :: young
            !! Young's Modulus for this element
        real(wp), intent(in) :: nu
            !! Poisson's Ratio for this element
        real(wp), dimension(:), intent(in)  :: xe
            !! Nodal coordinates of this element in undeformed configuration (see also [[plane42_ke]])
        real(wp), dimension(:), intent(in)  :: de
            !! Displacement field
            !!
            !! * `de(1:2)` = displacement of element node 1 along \(x\)- and \(y\)-axis, respectively
            !! * `de(3:4)` = displacement of element node 2 along \(x\)- and \(y\)-axis, respectively
            !! * etc...
        real(wp), dimension(:), intent(out) :: estress
            !! Stress at a point inside the element
            !!
            !! * `estress(1)` = \(\sigma_{11}\)
            !! * `estress(2)` = \(\sigma_{22}\)
            !! * `estress(3)` = \(\sigma_{12}\)
        real(wp), dimension(:), intent(out) :: estrain
            !! Strain at a point inside the element
            !!
            !! * `estrain(1)` = \(\epsilon_{11}\)
            !! * `estrain(2)` = \(\epsilon_{22}\)
            !! * `estrain(3)` = \(\epsilon_{12}\)
        real(wp) :: B(3, 8), cmat(3, 3), Ntilde(4,8)
        integer :: i,j
        real(wp) :: loc(3), w(3), xi, eta, det_J, factc

		! Define variable Gauss points and weighting
        loc = 0
        w = 0
        select case (no_gauss_points_s)
            case (1)
            	loc(1) = 0
                w(1) = 2
            case(2)
                loc(1) = 1_wp/sqrt(3.0_wp)
                loc(2) = -1_wp/sqrt(3.0_wp)
                w(1) = 1
                w(2) = 1
            case(3)
            	loc(1) = sqrt(0.6_wp)
                loc(2) = 0
                loc(3) = -sqrt(0.6_wp)
                w(1) = 5.0_wp/9.0_wp
                w(2) = 8.0_wp/9.0_wp
                w(3) = -w(1)
            end select

        ! Calculate strain for each gauss point
        estrain = 0
        do i = 1, no_gauss_points_s
            do j = 1, no_gauss_points_s
                xi = loc(i)
                eta = loc(j)
                ! Calculate B with shape subroutine
                B = 0
				call plane42_shape(xi, eta, Ntilde, B, det_J, xe)
        		! Compute element strain
        		estrain = estrain + matmul(B, de)
        	end do
        end do

        ! Build constitutive matrix (plane stress)
        cmat = 0
        factc = young/(1-nu**2)
        cmat(1,1) = factc
        cmat(1,2) = factc*nu
        cmat(2,1) = factc*nu
        cmat(2,2) = factc
        cmat(3,3) = factc*(1-nu)/2

        ! Compute element stress
        estress = matmul(cmat, estrain)

        ! Compute principal stress and direction
        ! print *, "stress:",estress
    end subroutine plane42_ss

end module plane42


! Name: Anantha Rao
! Reg no: 20181044
! This program provides the Euler Method to solve the differential equation y' = f(x,y)

program eulermethod
      implicit none
      real*8:: x,y, xwant, h, fxy
      integer:: niter, i

      x = 0.0; y=0.0; h=0.001; xwant=1.57
      niter = int((xwant - x)/h)
      open(unit=21, file="eulermethod.dat")

      do i=1,niter
      fxy = 1+y**2
      x = x+h
      y = y + h*fxy

      write(21,*) dfloat(i)*h, y
      end do

end program eulermethod

!function subroutine
real function f(x,y)
          real*8:: x,y
          f = 1 + y**2
end function


c -------------------------------------------------------------
C NCLFORTSTART
      SUBROUTINE QDTRNDMSG(Y,NPTS,YMSG,IOPT,IER,C)
      IMPLICIT NONE
      INTEGER NPTS, IOPT, IER
      DOUBLE PRECISION Y(NPTS)
      DOUBLE PRECISION YMSG, C(3)
C NCLEND
c                                      local
      INTEGER I
      DOUBLE PRECISION FN , SUMX , SUMY , SUMX2 , SUMX3 , SUMX4
     +               , SUMXY , SUMX2Y , XS , D , YAVE

      IER = 0

      IF (NPTS.LT.2) IER = 1
      IF (IER.NE.0) RETURN

      FN   = 0.0D0
      SUMY = 0.0D0
      DO I = 1,NPTS
         IF (Y(I).NE.YMSG) THEN
             FN   = FN + 1.0D0
             SUMY = SUMY + Y(I)
         END IF
      END DO

      IF (FN.GT.0.0D0) THEN
          YAVE = SUMY/FN
      ELSE
          IER  = 1
          YAVE = YMSG
       END IF

      IF (FN.EQ.1.0D0) THEN
          IER = 5
      END IF

      IF (IER.NE.0) THEN
          RETURN
      END IF
c                                 remove mean
      DO I = 1,NPTS
         IF (Y(I).NE.YMSG) THEN
             Y(I)   = Y(I) - YAVE
         END IF
      END DO
c
C QUADRATIC DETRENDING
C
      FN    = 0.0D0
      SUMX  = 0.0D0
      SUMY  = 0.0D0
      SUMX2 = 0.0D0
      SUMX3 = 0.0D0
      SUMX4 = 0.0D0
      SUMXY = 0.0D0
      SUMX2Y= 0.0D0
      DO I = 1,NPTS
         IF (Y(I).NE.YMSG) THEN
             FN    = FN + 1.0D0
             XS    = DBLE(I)
             SUMX  = SUMX  + XS
             SUMY  = SUMY  + Y(I)
             SUMX2 = SUMX2 + XS**2
             SUMX3 = SUMX3 + XS**3
             SUMX4 = SUMX4 + XS**4
             SUMXY = SUMXY + XS*Y(I)
             SUMX2Y= SUMX2Y+ XS**2*Y(I)
         END IF
      END DO
      D    = FN* (SUMX2*SUMX4-SUMX3**2) +
     +            SUMX* (SUMX3*SUMX2-SUMX*SUMX4) +
     +            SUMX2* (SUMX*SUMX3-SUMX2**2)
      C(1) = (SUMX2*SUMX4-SUMX3**2)*SUMY +
     +       (SUMX3*SUMX2-SUMX*SUMX4)*SUMXY +
     +       (SUMX*SUMX3-SUMX2**2)*SUMX2Y
      C(2) = (SUMX3*SUMX2-SUMX*SUMX4)*SUMY +
     +       (FN*SUMX4-SUMX2**2)*SUMXY +
     +       (SUMX*SUMX2-FN*SUMX3)*SUMX2Y
      C(3) = (SUMX*SUMX3-SUMX2**2)*SUMY +
     +       (SUMX*SUMX2-FN*SUMX3)*SUMXY + (FN*SUMX2-SUMX**2)*SUMX2Y
      C(1) = C(1)/D
      C(2) = C(2)/D
      C(3) = C(3)/D

      DO I = 1,NPTS
         IF (Y(I).NE.YMSG) THEN
             Y(I) = Y(I) - (C(1)+C(2)*DBLE(I)+C(3)*DBLE(I)**2)
         END IF
      END DO

C JAN 14, 2013: IOPT=1 [True] matches 'dtrend_msg'
C IOPT=1 means True in NCL
      IF (IOPT.EQ.1) RETURN

C Add the mean back in
C C C IF (IOPT.NE.0) THEN
          DO I = 1,NPTS
             IF (Y(I).NE.YMSG) THEN
                 Y(I)   = Y(I) + YAVE
             END IF
          END DO
C C C END IF
c
      RETURN
      END


MODULE Exp_Mod
IMPLICIT NONE

INTERFACE OPERATOR (.pow.)    ! Using ** instead would overload the standard exponentiation operator
  MODULE PROCEDURE Intexp, Realexp
END INTERFACE

CONTAINS

  FUNCTION Intexp (base, exponent)
    INTEGER :: Intexp
    INTEGER, INTENT(IN) :: base, exponent
    INTEGER :: i

    IF (exponent < 0) THEN
       IF (base == 1) THEN
          Intexp = 1
       ELSE
          Intexp = 0
       END IF
       RETURN
    END IF
    Intexp = 1
    DO i = 1, exponent
      Intexp = Intexp * base
    END DO
  END FUNCTION IntExp

  FUNCTION Realexp (base, exponent)
    REAL :: Realexp
    REAL, INTENT(IN) :: base
    INTEGER, INTENT(IN) :: exponent
    INTEGER :: i

    Realexp = 1.0
    IF (exponent < 0) THEN
       DO i = exponent, -1
          Realexp = Realexp / base
       END DO
    ELSE
       DO i = 1, exponent
          Realexp = Realexp * base
       END DO
    END IF
  END FUNCTION RealExp
END MODULE Exp_Mod

PROGRAM EXAMPLE
USE Exp_Mod
  WRITE(*,*) 2.pow.30, 2.0.pow.30
END PROGRAM EXAMPLE


SUBROUTINE p53(input_file,output_file)
!-------------------------------------------------------------------------
! Program 5.3 Three-dimensional analysis of an elastic solid using
!             8-, 14- or 20-node brick hexahedra. Mesh numbered in x-y
!             planes then in the z-direction.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=70),INTENT(IN) :: input_file
 CHARACTER(len=70),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::fixed_freedoms,i,iel,k,loaded_nodes,ndim=3,ndof,nels,neq,nip,   &
   nlen,nn,nprops=2,np_types,nod,nodof=3,nr,nst=6,nxe,nye,nze
 REAL(iwp)::det,penalty=1.0e20_iwp,zero=0.0_iwp
 CHARACTER(LEN=15)::argv,element='hexahedron'
!-----------------------dynamic arrays-----------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),kdiag(:),nf(:,:), &
   no(:),node(:),num(:),sense(:)
 REAL(iwp),ALLOCATABLE::bee(:,:),coord(:,:),dee(:,:),der(:,:),deriv(:,:), &
   eld(:),fun(:),gc(:),g_coord(:,:),jac(:,:),km(:,:),kv(:),loads(:),      &
   points(:,:),prop(:,:),sigma(:),value(:),weights(:),x_coords(:),        &
   y_coords(:),z_coords(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nod,nxe,nye,nze,nip,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye,nze)
 ndof=nod*nodof
 ALLOCATE(nf(nodof,nn),points(nip,ndim),dee(nst,nst),coord(nod,ndim),     &
   jac(ndim,ndim),der(ndim,nod),deriv(ndim,nod),g(ndof),bee(nst,ndof),    &
   km(ndof,ndof),eld(ndof),sigma(nst),g_g(ndof,nels),g_coord(ndim,nn),    &
   g_num(nod,nels),weights(nip),num(nod),prop(nprops,np_types),           &
   x_coords(nxe+1),y_coords(nye+1),z_coords(nze+1),etype(nels),fun(nod),  &
   gc(ndim))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)x_coords,y_coords,z_coords
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(loads(0:neq),kdiag(neq))
 kdiag=0
!-----------------------loop the elements to find global arrays sizes-----
 elements_1: DO iel=1,nels
   CALL hexahedron_xz(iel,x_coords,y_coords,z_coords,coord,num)
   CALL num_to_g(num,nf,g)
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   g_g(:,iel)=g
   CALL fkdiag(kdiag,g)
 END DO elements_1
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)))
 WRITE(11,'(2(A,I5))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
!-----------------------element stiffness integration and assembly--------
 CALL sample(element,points,weights)
 kv=zero
 elements_2: DO iel=1,nels
   CALL deemat(dee,prop(1,etype(iel)),prop(2,etype(iel)))
   num=g_num(:,iel)
   g=g_g(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   km=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)
     CALL beemat(bee,deriv)
     km=km+MATMUL(MATMUL(TRANSPOSE(bee),dee),bee)*det*weights(i)
   END DO gauss_pts_1
   CALL fsparv(kv,km,g,kdiag)
 END DO elements_2
 loads=zero
 READ(10,*)loaded_nodes
 IF(loaded_nodes/=0)READ(10,*)(k,loads(nf(:,k)),i=1,loaded_nodes)
 READ(10,*)fixed_freedoms
 IF(fixed_freedoms/=0)THEN
   ALLOCATE(node(fixed_freedoms),sense(fixed_freedoms),                   &
     value(fixed_freedoms),no(fixed_freedoms))
   READ(10,*)(node(i),sense(i),value(i),i=1,fixed_freedoms)
   DO i=1,fixed_freedoms
     no(i)=nf(sense(i),node(i))
   END DO
   kv(kdiag(no))=kv(kdiag(no))+penalty
   loads(no)=kv(kdiag(no))*value
 END IF
!-----------------------equation solution---------------------------------
 CALL sparin(kv,kdiag)
 CALL spabac(kv,loads,kdiag)
 loads(0)=zero
 WRITE(11,'(/A)')"  Node   x-disp      y-disp      z-disp"
 DO k=1,nn
   WRITE(11,'(I5,3E12.4)')k,loads(nf(:,k))
 END DO
!-----------------------recover stresses at nip integrating points--------
 nip=1
 DEALLOCATE(points,weights)
 ALLOCATE(points(nip,ndim),weights(nip))
 CALL sample(element,points,weights)
 WRITE(11,'(/A,I2,A)')" The integration point (nip=",nip,") stresses are:"
 WRITE(11,'(A,/,A)')"    Element     x-coord     y-coord     z-coord",    &
   "    sig_x       sig_y       sig_z       tau_xy      tau_yz      tau_zx"
 elements_3: DO iel=1,nels
   CALL deemat(dee,prop(1,etype(iel)),prop(2,etype(iel)))
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   eld=loads(g)
   gauss_pts_2: DO i=1,nip
     CALL shape_der(der,points,i)
     CALL shape_fun(fun,points,i)
     gc=MATMUL(fun,coord)
     jac=MATMUL(der,coord)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     CALL beemat(bee,deriv)
     sigma=MATMUL(dee,MATMUL(bee,eld))
     WRITE(11,'(I8,4X,3E12.4)')iel,gc
     WRITE(11,'(6E12.4)')sigma
   END DO gauss_pts_2
 END DO elements_3

END SUBROUTINE p53