      SUBROUTINE TEVLS (N,D,E2,IERR)
C
      INTEGER         I          ,J          ,L          ,M          ,
     1                N          ,II         ,L1         ,MML        ,
     2                IERR
      REAL            D(N)       ,E2(N)
      REAL            B          ,C          ,F          ,G          ,
     1                H          ,P          ,R          ,S          ,
     2                MACHEP
C
C     REAL SQRT,ABS,SIGN
C
      COMMON /CBLKT/  NPP        ,K          ,EPS     ,CNV        ,
     1                NM         ,NCMPLX     ,IK
C
C     THIS SUBROUTINE IS A MODIFICATION OF THE EISPACK SUBROUTINE TQLRAT
C     ALGORITHM 464, COMM. ACM 16, 689(1973) BY REINSCH.
C
C     THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
C     TRIDIAGONAL MATRIX BY THE RATIONAL QL METHOD.
C
C     ON INPUT-
C
C        N IS THE ORDER OF THE MATRIX,
C
C        D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX,
C
C        E2 CONTAINS THE                SUBDIAGONAL ELEMENTS OF THE
C          INPUT MATRIX IN ITS LAST N-1 POSITIONS.  E2(1) IS ARBITRARY.
C
C      ON OUTPUT-
C
C        D CONTAINS THE EIGENVALUES IN ASCENDING ORDER.  IF AN
C          ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
C          ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
C          THE SMALLEST EIGENVALUES,
C
C        E2 HAS BEEN DESTROYED,
C
C        IERR IS SET TO
C          ZERO       FOR NORMAL RETURN,
C          J          IF THE J-TH EIGENVALUE HAS NOT BEEN
C                     DETERMINED AFTER 30 ITERATIONS.
C
C     QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO B. S. GARBOW,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C
C
C     ********** EPS IS A MACHINE DEPENDENT PARAMETER SPECIFYING
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.
C
C                **********
C
      IERR = 0
      IF (N .EQ. 1) GO TO 115
C
      DO 101 I=2,N
         E2(I-1) = E2(I)*E2(I)
  101 CONTINUE
C
      F = 0.0
      B = 0.0
      E2(N) = 0.0
C
      DO 112 L=1,N
         J = 0
         H = EPS*(ABS(D(L))+SQRT(E2(L)))
         IF (B .GT. H) GO TO 102
         B = H
         C = B*B
C
C     ********** LOOK FOR SMALL SQUARED SUB-DIAGONAL ELEMENT **********
C
  102    DO 103 M=L,N
            IF (E2(M) .LE. C) GO TO 104
C
C     ********** E2(N) IS ALWAYS ZERO, SO THERE IS NO EXIT
C                THROUGH THE BOTTOM OF THE LOOP **********
C
  103    CONTINUE
C
  104    IF (M .EQ. L) GO TO 108
  105    IF (J .EQ. 30) GO TO 114
         J = J+1
C
C     ********** FORM SHIFT **********
C
         L1 = L+1
         S = SQRT(E2(L))
         G = D(L)
         P = (D(L1)-G)/(2.0*S)
         R = SQRT(P*P+1.0)
         D(L) = S/(P+SIGN(R,P))
         H = G-D(L)
C
         DO 106 I=L1,N
            D(I) = D(I)-H
  106    CONTINUE
C
         F = F+H
C
C     ********** RATIONAL QL TRANSFORMATION **********
C
         G = D(M)
         IF (G .EQ. 0.0) G = B
         H = G
         S = 0.0
         MML = M-L
C
C     ********** FOR I=M-1 STEP -1 UNTIL L DO -- **********
C
         DO 107 II=1,MML
            I = M-II
            P = G*H
            R = P+E2(I)
            E2(I+1) = S*R
            S = E2(I)/R
            D(I+1) = H+S*(H+D(I))
            G = D(I)-E2(I)/G
            IF (G .EQ. 0.0) G = B
            H = G*P/R
  107    CONTINUE
C
         E2(L) = S*G
         D(L) = H
C
C     ********** GUARD AGAINST UNDERFLOWED H **********
C
         IF (H .EQ. 0.0) GO TO 108
         IF (ABS(E2(L)) .LE. ABS(C/H)) GO TO 108
         E2(L) = H*E2(L)
         IF (E2(L) .NE. 0.0) GO TO 105
  108    P = D(L)+F
C
C     ********** ORDER EIGENVALUES **********
C
         IF (L .EQ. 1) GO TO 110
C
C     ********** FOR I=L STEP -1 UNTIL 2 DO -- **********
C
         DO 109 II=2,L
            I = L+2-II
            IF (P .GE. D(I-1)) GO TO 111
            D(I) = D(I-1)
  109    CONTINUE
C
  110    I = 1
  111    D(I) = P
  112 CONTINUE
C
      IF (ABS(D(N)) .GE. ABS(D(1))) GO TO 115
      NHALF = N/2
      DO 113 I=1,NHALF
         NTOP = N-I
         DHOLD = D(I)
         D(I) = D(NTOP+1)
         D(NTOP+1) = DHOLD
  113 CONTINUE
      GO TO 115
C
C     ********** SET ERROR -- NO CONVERGENCE TO AN
C                EIGENVALUE AFTER 30 ITERATIONS **********
C
  114 IERR = L
  115 RETURN
C
C     ********** LAST CARD OF TQLRAT **********
C
      END


C++------------------------------------------------------------------
C GRADIENT1
C Program to compute the gradient map of an image
C From QUICKGRAD2 (Bill Sparks)
C
C Syntax:
C   RUNS GRADIENT1 in_image out_image [Y/N: manual entry of sky/noise ?]
C               [[sky_value,noise]]
C Examples:
C   RUNS GRADIENT1 test test_grad1 N
C   RUNS GRADIENT1 test test_grad1 Y 1230.4,23.4
C
C JLP
C Version of 25-06-94
C--------------------------------------------------------------------
	PROGRAM GRADIENT1
	INTEGER*4 PNTR_IN,PNTR_OUT,PNTR_WORK
	INTEGER*4 MADRID(1)
	CHARACTER NAMEIN*40,NAMEOUT*40,COMMENTS*80,ANS*1
	COMMON /VMR/MADRID
10	FORMAT(A)

C To allow for direct input of parameters in the command line:
	CALL JLP_BEGIN

	WRITE(6,81)
81	FORMAT(' Program GRADIENT1   Version 25-06-94',/,
     1	' To compute a log-gradient map')

C Inquire about the format of the files :
	CALL JLP_INQUIFMT

C Read the input image :
	PRINT *,' Input image ?'
	READ(5,10) NAMEIN
	CALL JLP_VM_READIMAG(PNTR_IN,NX,NY,NAMEIN,COMMENTS)

	PRINT *,' Output image ?'
	READ(5,10) NAMEOUT
	CALL JLP_GETVM(PNTR_OUT,NX*NY*4)
	CALL JLP_GETVM(PNTR_WORK,NX*NY*4)

C Entering the level of the sky and the noise of the image :
	PRINT *,' Do you know the sky level and',
     1	' the noise of the image (N)?'
	READ(5,10) ANS
	  IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')THEN
	    PRINT *,' Enter the sky level and the noise :'
	    READ(5,*) SKY,SIGMA
	  ELSE
C Else computing it directly from the image :
	    CALL AUTO_SKY(MADRID(PNTR_IN),NX,NY,NX,SKY,SIGMA)
	    PRINT *,' SKY, SIGMA :',SKY,SIGMA
	  ENDIF

C Compute the gradient map :
	CALL GRADIENT1_SUB(MADRID(PNTR_IN),MADRID(PNTR_OUT),
     1	MADRID(PNTR_WORK),NX,NY,NX,SKY,SIGMA)

C Write the output in a file :
	IN=INDEX(NAMEIN,'  ')-1
	WRITE(COMMENTS,35)NAMEIN(1:IN)
35	FORMAT(' Gradient map of: ',A,' //')
	CALL JLP_WRITEIMAG(MADRID(PNTR_OUT),NX,NY,NX,NAMEOUT,COMMENTS)

	CALL JLP_END
	STOP
	END
C------------------------------------------------------------------
C Subroutine GRADIENT1_SUB which computes the gradient map
C
C------------------------------------------------------------------
	SUBROUTINE GRADIENT1_SUB(IM,GRADIENT,WORK,NX,NY,IDIM,
     1	BACK,RMS)
	REAL*4 IM(IDIM,*),GRADIENT(IDIM,*),WORK(IDIM,*),C1(5)
	CHARACTER CNUM*1
c
c Filter row - assumed antisymmetric
c
	DATA C1/0.25,0.50,1,0.50,0.25/
c
c Subroutine to generate a gradient map by convolution with a kernel
c and quadratic addition of the 2 components.
c Output is log of image with offset Out=Kernel*(Log(Image-Offset))
c
	OFFSET=BACK-3.0*RMS

C Taking the logarithm of the whole image :
	BACKLOG=ALOG10(BACK-OFFSET)
	DO J=1,NY
	 DO I=1,NX
	 WORK1=IM(I,J)-OFFSET
	   IF(WORK1.GT.0)THEN
 	    WORK(I,J)=ALOG10(WORK1)
	   ELSE
c Set values below offset to back
	    WORK(I,J)=BACKLOG
	   ENDIF
	 END DO
	END DO

C Now scanning the image :

	do j=3,NY-2

	  do i=3,NX-2

	     SUM1=0.
	     DO I1=I-2,I+2
	      K=I1-I+3
	      SUM1=C1(K)*(WORK(I1,J-1)-WORK(I1,J+1)
     1	+0.50*(WORK(I1,J-2)-WORK(I1,J+2)))+SUM1
	     END DO

	     SUM2=0.
	     DO J1=J-2,J+2
	      K=J1-J+3
	      SUM2=C1(K)*(WORK(I-1,J1)-WORK(I+1,J1)
     1	+0.50*(WORK(I-2,J1)-WORK(I+2,J1)))+SUM2
	     END DO

	      GRADIENT(I,J)=SQRT(SUM1*SUM1+SUM2*SUM2)
20	end do
	end do
c
80	return
	end
C***********************************************************************
	include 'jlpsub:auto_sky.for'


! { dg-do run }
! { dg-require-effective-target fortran_large_real }
! Check that the random_seed for real(10) or real(16) exists and that
! real(8) and real(10) or real(16) random number generators
! return the same sequence of values.
! Mostly copied from random_2.f90
program random_4
  integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1)

  integer, dimension(:), allocatable :: seed
  real(kind=8), dimension(10) :: r8
  real(kind=k), dimension(10) :: r10
  real, parameter :: delta = 1.d-10
  integer n

  call random_seed (size=n)
  allocate (seed(n))
  call random_seed (get=seed)
  ! Test both array valued and scalar routines.
  call random_number(r8)
  call random_number (r8(10))

  ! Reset the seed and get the real(8) values.
  call random_seed (put=seed)
  call random_number(r10)
  call random_number (r10(10))

  if (any ((r8 - r10) .gt. delta)) call abort
end program random_4


program test_1
use M_matrix, only : lala, get_from_lala, put_into_lala
implicit none
integer,parameter :: lda=10
integer           :: m,n, i,j, ierr
doubleprecision   :: arr(lda,lda),x(lda,lda)
logical           :: logs=.false.
   !!logs=.true.
   !!call lala(2000,echo=.true.)
   call lala( 'display(ones(80,1)''*46)')
   call lala( 'display(''test_1'');clear;')
   if(logs)call lala( 'diary(''test_1.log'');')
   call lala( [ character(len=256) :: &
'// -----------------------------------------------------------------            ',&
'titles=[''GNP deflator''                                                          ',&
'        ''GNP         ''                                                          ',&
'        ''Unemployment''                                                          ',&
'        ''Armed Force ''                                                          ',&
'        ''Population  ''                                                          ',&
'        ''Year        ''                                                          ',&
'        ''Employment  ''];                                                        ',&
'// -----------------------------------------------------------------            ',&
'data = [                                                                        ',&
'    83.0  234.289  235.6  159.0  107.608  1947  60.323                          ',&
'    88.5  259.426  232.5  145.6  108.632  1948  61.122                          ',&
'    88.2  258.054  368.2  161.6  109.773  1949  60.171                          ',&
'    89.5  284.599  335.1  165.0  110.929  1950  61.187                          ',&
'    96.2  328.975  209.9  309.9  112.075  1951  63.221                          ',&
'    98.1  346.999  193.2  359.4  113.270  1952  63.639                          ',&
'    99.0  365.385  187.0  354.7  115.094  1953  64.989                          ',&
'   100.0  363.112  357.8  335.0  116.219  1954  63.761                          ',&
'   101.2  397.469  290.4  304.8  117.388  1955  66.019                          ',&
'   104.6  419.180  282.2  285.7  118.734  1956  67.857                          ',&
'   108.4  442.769  293.6  279.8  120.445  1957  68.169                          ',&
'   110.8  444.546  468.1  263.7  121.950  1958  66.513                          ',&
'   112.6  482.704  381.3  255.2  123.366  1959  68.655                          ',&
'   114.2  502.601  393.1  251.4  125.368  1960  69.564                          ',&
'   115.7  518.173  480.6  257.2  127.852  1961  69.331                          ',&
'   116.9  554.894  400.7  282.7  130.081  1962  70.551                          ',&
'   ];                                                                           ',&
'// -----------------------------------------------------------------            ',&
'short                                                                           ',&
'X = data;                                                                       ',&
'[n,p] = shape(X)                                                                 ',&
'mu = ones(1,n)*X/n                                                              ',&
'X = X - ones(n,1)*mu;  X = X/diag(sqrt(diag(X''*X)))                            ',&
'corr = X''*X                                                                    ',&
'y = data(:,p); X = [ones(y) data(:,1:p-1)];                                     ',&
'long e                                                                          ',&
'beta = X\y                                                                      ',&
'// -----------------------------------------------------------------            ',&
'display(''EXPECTED and BETA should be the same'');                                ',&
'eps                                                                             ',&
'expected = [ ...                                                                ',&
'        -3.482258634594421D+03                                                  ',&
'         1.506187227124484D-02                                                  ',&
'        -3.581917929257409D-02                                                  ',&
'        -2.020229803816908D-02                                                  ',&
'        -1.033226867173703D-02                                                  ',&
'        -5.110410565317738D-02                                                  ',&
'         1.829151464612817D+00                                                  ',&
'];                                                                              ',&
'delta=expected-beta                                                             ',&
'<M,N>=shape(expected);                                                           ',&
'for i=1:M, for j=1:N, if abs(delta(i,j))<=eps, delta(i,j)=0; else, delta(i,j)=-1;',&
'delta                                                                           ',&
'if delta=zeros(M,N),display(''PASSED''),else,display(''FAILED'')                    ',&
'// -----------------------------------------------------------------            ',&
''])
end program test_1


!##############################################################################
!# Tutorial 019b: Projection FEM spaces
!##############################################################################
!# Computes a Q0 FE function representing the cell size.
!# Projects the Q0 solution to Q1 via a projection, so one receives
!# the mean cell size in each grid point.
!##############################################################################

module tutorial019b

  ! Include basic Feat-2 modules
  use fsystem
  use storage
  use genoutput

  use boundary
  use triangulation
  use meshgeneration

  use element
  use spatialdiscretisation
  use linearsystemscalar
  use bilinearformevaluation

  use domainintegration
  use collection

  use matrixio
  use vectorio
  use ucd

  use analyticprojection
  use spdiscprojection

  implicit none
  private

  public :: start_tutorial019b

contains

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

!<subroutine>

  subroutine ffunction (cderivative, rdiscretisation, &
      nelements, npointsPerElement, Dpoints, IdofsTest, rdomainIntSubset, &
      Dvalues, rcollection)

!<description>
  ! This subroutine returns values of an analytically given function
  ! at specific points in a domain.
!</description>

!<input>
  ! This is a DER_xxxx derivative identifier (from derivative.f90) that
  ! specifies what to compute: DER_FUNC=function value, DER_DERIV_X=x-derivative,...
  ! The result must be written to the Dvalue-array below.
  integer, intent(in) :: cderivative

  ! The discretisation structure that defines the basic shape of the
  ! triangulation with references to the underlying triangulation,
  ! analytic boundary boundary description etc.
  type(t_spatialDiscretisation), intent(in) :: rdiscretisation

  ! Number of elements, where the coefficients must be computed.
  integer, intent(in) :: nelements

  ! Number of points per element, where the coefficients must be computed
  integer, intent(in) :: npointsPerElement

  ! This is an array of all points on all the elements where coefficients
  ! are needed.
  ! DIMENSION(NDIM2D,npointsPerElement,nelements)
  ! Remark: This usually coincides with rdomainSubset%p_DcubPtsReal.
  real(DP), dimension(:,:,:), intent(in) :: Dpoints

  ! An array accepting the DOF`s on all elements trial in the trial space.
  ! DIMENSION(\#local DOF`s in trial space,Number of elements)
  integer, dimension(:,:), intent(in) :: IdofsTest

  ! This is a t_domainIntSubset structure specifying more detailed information
  ! about the element set that is currently being integrated.
  ! It is usually used in more complex situations (e.g. nonlinear matrices).
  type(t_domainIntSubset), intent(in) :: rdomainIntSubset

  ! Optional: A collection structure to provide additional
  ! information to the coefficient routine.
  type(t_collection), intent(inout), optional :: rcollection

!</input>

!<output>
  ! This array has to receive the values of the (analytical) function
  ! in all the points specified in Dpoints, or the appropriate derivative
  ! of the function, respectively, according to cderivative.
  !   DIMENSION(npointsPerElement,nelements)
  real(DP), dimension(:,:), intent(out) :: Dvalues
!</output>

!</subroutine>

    ! local variables
    integer :: ipt, iel
    real(DP) :: dvol
    real(DP), dimension(:), pointer :: p_DcellSize
    integer, dimension(:), pointer :: p_Ielements

    ! From the triangulation, get an array with the cell size
    call storage_getbase_double (&
        rdiscretisation%p_rtriangulation%h_DelementVolume,p_DcellSize)

    ! Get the list of real element IDs which are behind our
    ! local element numbers 1..nelements
    p_Ielements => rdomainIntSubset%p_Ielements

    ! In every point on every element, return the value of our function.
    do iel = 1,nelements

      ! Volume of the element
      dvol = p_DcellSize (p_Ielements(iel))

      do ipt = 1,npointsPerElement

        ! Value of the function is the element volume
        Dvalues(ipt,iel) = dvol

      end do
    end do

  end subroutine

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

  subroutine start_tutorial019b

    ! Declare some variables.
    type(t_boundary) :: rboundary
    type(t_triangulation) :: rtriangulation
    character(LEN=SYS_STRLEN) :: spredir,spostdir
    type(t_spatialDiscretisation) :: rdiscrQ0, rdiscrQ1
    type(t_vectorScalar) :: rxQ0, rxQ1
    type(t_ucdExport) :: rexport

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 019b")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Read the underlying domain
    ! and the mesh
    ! =================================

    if (sys_getenv_string("PREDIR",spredir)) then
      call boundary_read_prm(rboundary, trim(spredir)//"/bench1.prm")
    else
      call boundary_read_prm(rboundary, "pre/bench1.prm")
    end if
    ! The mesh must always be in "standard" format to work with it.
    ! First read, then convert to standard, based on rboundary.
    if (sys_getenv_string("PREDIR",spredir)) then
      call tria_readTriFile2D (rtriangulation, trim(spredir)//"/bench1.tri", rboundary)
    else
      call tria_readTriFile2D (rtriangulation, "pre/bench1.tri", rboundary)
    end if
    call tria_initStandardMeshFromRaw (rtriangulation, rboundary)

    ! =================================
    ! Discretise with Q0 and Q1.
    !
    ! Create a structure rdiscretisation
    ! which describes the discretisation.
    ! =================================

    call spdiscr_initDiscr_simple (rdiscrQ0,EL_Q0_2D,rtriangulation)
    call spdiscr_initDiscr_simple (rdiscrQ1,EL_Q1_2D,rtriangulation)

    ! =================================
    ! Create two vectors based on Q0 and Q1
    ! =================================

    call lsyssc_createVector (rdiscrQ0,rxQ0)
    call lsyssc_createVector (rdiscrQ1,rxQ1)

    ! =================================
    ! Projection of the cell size to Q0
    ! =================================

    call anprj_discrDirect (rxQ0, ffunction)

    ! =================================
    ! Projection Q0 to Q1
    ! =================================

    call lsyssc_clearVector (rxQ1)

    call spdp_projectSolutionScalar (rxQ0,rxQ1)

    ! =================================
    ! Write a VTK file with the mesh
    ! and this solution vector.
    ! =================================
    call output_line ("Writing file 'post/tutorial019b.vtk'.")

    ! Open
    if (sys_getenv_string("POSTDIR",spostdir)) then
      call ucd_startVTK (rexport,UCD_FLAG_STANDARD,rtriangulation,&
                       trim(spostdir)//"/tutorial019b.vtk")
    else
    call ucd_startVTK (rexport,UCD_FLAG_STANDARD,rtriangulation,&
                       "post/tutorial019b.vtk")
    end if

    ! Pass the vectors as solutions.
    call ucd_addVectorByElement (rexport, "x_q0", UCD_VAR_STANDARD, rxQ0)
    call ucd_addVectorByVertex (rexport, "x_q1", UCD_VAR_STANDARD, rxQ1)

    ! Write / close
    call ucd_write (rexport)
    call ucd_release (rexport)

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the vectors
    call lsyssc_releaseVector (rxQ1)
    call lsyssc_releaseVector (rxQ0)

    ! Release discretisation structures
    call spdiscr_releaseDiscr (rdiscrQ1)
    call spdiscr_releaseDiscr (rdiscrQ0)

    ! Release the triangulation and the boundary
    call tria_done (rtriangulation)
    call boundary_release (rboundary)

  end subroutine

end module


program test_model_sarima

    use stdlib_error, only: error_stop
    use forlab, only: file, disp
    use fortsa_model, only: sarima_init, sarima_setMethod, sarima_predict, &
                            sarima_exec, sarima_summary, sarima_free
    use, intrinsic :: iso_c_binding, only: c_ptr, c_null_ptr
    implicit none
    integer :: i, N, d, L
    real(8), allocatable :: inp(:)
    integer :: p, q
    integer :: s, p_, d_, q_
    real(8), allocatable :: phi(:), theta(:)
    real(8), allocatable :: phi_(:), theta_(:)
    real(8), allocatable :: xpred(:), amse(:)
    type(c_ptr) :: obj = c_null_ptr
    target :: obj
    type(file) :: infile

    p = 0
    d = 1
    q = 1
    s = 12
    p_ = 0
    d_ = 1
    q_ = 1

    L = 5

    allocate (phi(p), theta(q), phi_(p_), theta_(q_))
    allocate (xpred(L), amse(L))

    infile = file('example/data/seriesG.txt')
    if (.not. infile%exist()) call error_stop('Error: file not exist, '//infile%filename)
    call infile%open()
    N = infile%countlines()
    allocate (inp(N))

    do i = 1, N
        read (infile%unit, *) inp(i)
        inp(i) = log(inp(i))
    end do
    call infile%close()

    obj = sarima_init(p, d, q, s, p_, d_, q_, N)
    call sarima_setMethod(obj, 0)   !! Method 0 ("MLE") is default so this step is unnecessary. The method also accepts values 1 ("CSS") and 2 ("Box-Jenkins")
        !! sarima_setOptMethod(obj, 7);// Method 7 ("BFGS with More Thuente Line Search") is default so this step is unnecessary. The method also accepts values 0,1,2,3,4,5,6. Check the documentation for details.
    call sarima_exec(obj, inp)
    call sarima_summary(obj)
        !! Predict the next 5 values using the obtained ARIMA model
    call sarima_predict(obj, inp, L, xpred, amse)
    call disp(xpred, 'Predicted Values : ')

    call disp(sqrt(amse), 'Standard Errors : ')

    call sarima_free(obj)
    deallocate (inp, phi, theta, phi_, theta_, xpred, amse)

end program test_model_sarima


program vin
  integer :: val2(2,5), val3(5,5),  i, j

  do i = 1,5
    do j = 1,2
      val2(j,i) = mod(i * j, i + j)
    end do
  end do

  val3 = 10

  print *, (val2)
  print *, transpose(val2)

  val3 = transpose(val3)
  print *, val3

end program vin


C Work performed under the auspices of the U.S. Department of Energy
C by Lawrence Livermore National Laboratory under contract number
C W-7405-Eng-48.
C
C-----------------------------------------------------------------------
C
C             Preconditioner Routines for Sparse Problems
C                          4 December 1995
C
C The following triple of subroutines -- SSPSETUP, SJACILU and
C SPSOLILU -- provides a general-purpose sparse incomplete LU (ILU)
C preconditioner matrix for use with the SDASPK solver, with the Krylov
C linear system method.  When using SDASPK to solve a problem
C G(t,y,y') = 0, whose iteration matrix (Jacobian)
C    J = dG/dy + c * dG/dy'  (c = scalar)
C is a general sparse matrix, these routines can be used to generate
C an approximation to J as the preconditioner and to solve the resulting
C sparse linear system, in conjunction with the Krylov method option
C (INFO(12) = 1) in SDASPK.
C
C The incomplete LU factorization is achieved via one of two routines
C from the SPARSKIT library available from Yousef Saad at the
C University of Minnesota.  The two routines are ILUT and ILUTP.
C See below for detailed descriptions of these routines.
C
C Descriptions of the above routines are as follows:
C
C SSPSETUP   - Setup routine for the preconditioner.  This routine
C              checks the user input for illegal values, and calculates
C              the minimum length needed for preconditioner workspace
C              arrays in SDASPK.
C
C SJACILU   -  This routine is a version of JAC for SDASPK.
C              It uses finite-differences to calculate the Jacobian
C              matrix J in sparse format, and then performs an
C              incomplete LU factorization using either ILUT or ILUTP.
C              SJACILU must be declared EXTERNAL in the user's main
C              program and passed through to SDASPK.
C
C SPSOLILU   - This routine is a version of PSOL for SDASPK.
C              It uses the incomplete factorization calculated in
C              SJACILU.  SPSOLILU must be declared EXTERNAL in the
C              user's main program and passed through to SDASPK.
C
C
C The routines ILUT and ILUTP are part of the SPARSKIT library,
C and are contained in the file 'ssparsk.f'.  ILUT performs an
C incomplete LU factorization of a sparse matrix using a dual
C thresholding technique based on a drop tolerance (TOLILUT below)
C and a level of fill-in parameter (LFILILUT).  LFILILUT controls
C the amount of fill-in allowed in the factorization (limited to a
C maximum of 2*LFILILUT*NEQ, but normally much less).  Increasing
C LFILILUT will generally make the ILU factorization more accurate.
C TOLILUT also controls the accuracy of the ILU factorization via
C a drop tolerance based on element size.  Descreasing TOLILUT
C will increase the amount of fill-in and make for a more accurate
C factorization.  ILUTP is a variant of ILUT that in addition performs
C pivoting based on a tolerance ratio PERMTOL.
C
C An important aspect of using incomplete factorization techniques
C is that of reordering the rows and columns in the Jacobian matrix
C J before performing the ILU.  In this package, this is accomplished
C via the parameter IREORDER, which when equal to 1 performs
C a reverse Cuthill-McKee (RCM) reordering before performing the
C ILU factorization.  Based on the limited amount of testing done so
C far, RCM seems the best overall choice.  It is possible to include
C a different reordering technique if desired.
C
C To use these routines in conjunction with SDASPK, the user's calling
C program should include the following, in addition to setting the other
C SDASPK input parameters.
C
C (a) Dimension the array IPAR to have length at least 30, and load the
C     following parameters into IPAR as
C
C      IPAR(1)  = ML        - The lower bandwidth used in calculating
C                             the approximate Jacobian matrix.
C      IPAR(2)  = MU        - The upper bandwidth used in calculating
C                             the approximate Jacobian matrix.
C      IPAR(3)  = LENPFAC   - The average number of nonzeros in a
C                             row of the Jacobian matrix.  The
C                             maximum of nonzeros allowed in the
C                             Jacobian matrix is NNZMX = LENPFAC*NEQ.
C                             LENPFAC must be .GE. 2.
C      IPAR(4)  = LENPLUFAC - The average amount of fill-in per row
C                             in the factored Jacobian matrix.  The
C                             maximum number of nonzeros allowed
C                             in the factored Jacobian matrix is
C                             LENPLUMX = NNZMX + LENPLUFAC*NEQ.
C                             LENPLUFAC must be .GE. 2.
C      IPAR(5)  = IPREMETH  - Preconditioner type flag.
C                             =1 means ILUT preconditioner used
C                             =2 means ILUTP preconditioner used
C      IPAR(6)  = LFILILUT  - Fill-in parameter for ILUT and ILUTP.
C                             The largest LFILILUT elements per row
C                             of the L and U factors are kept.  Each
C                             row of L and U will have a maximum of
C                             LFILILUT elements in addition to
C                             their original number of nonzero
C                             elements.
C      IPAR(7)  = IREORDER  - Reordering flag.
C                             =0 means that no reordering of the
C                                rows and columns of the Jacobian
C                                matrix is performed before the
C                                incomplete factorization is performed.
C                             =1 means that a reverse Cuthill-McKee
C                                (RCM) reordering is performed.
C      IPAR(8)  = ISRNORM   - Row norm flag.
C                             =1 means that row norms of the Jacobian
C                                matrix are computed and used as
C                                row scalings when solving the
C                                preconditioner linear system P*x=b.
C                             =0 means no row norm scaling is used.
C      IPAR(9)  = NORMTYPE  - Type of row norm scaling for ISRNORM
C                             =0 means max-norm is used.
C                             =1 means 1-norm is used.
C                             =2 means 2-norm is used.
C      IPAR(10) = JACOUT    - Output Jacobian flag.
C                             =1 means write the calculated Jacobian
C                                matrix along with the initial value of
C                                the residual G to a file pointed to by
C                                the logical unit number in IPAR(29).
C                                This is done after any reordering and
C                                scaling is performed.  The user must
C                                have attached the unit number to a
C                                file before calling SDASPK.  The
C                                integration is then halted by setting
C                                IRES = -2 (and a false message about
C                                failure to initialize is printed).
C                             =0 means no Jacobian matrix output.
C                             The matrix and initial residual G are
C                             written in Boeing-Harwell format.
C      IPAR(11) = JSCALCOL  - Flag for scaling columns of the
C                             Jacobian matrix by the inverses of the
C                             elements in the EWT array.
C                             =0 means no scaling.
C                             =1 means perform scaling.
C
C      IPAR(21:28)          - Used to hold pointer information.
C      IPAR(29)             - Logical unit number to write matrix output
C                             file on.  Only needed when JACOUT = 1.
C      IPAR(30)             - On return from SDASPK, this value
C                             holds the number of calls to the
C                             RES routine used in the preconditioner
C                             evaluations.
C
C (b) Dimension the array RPAR to have length at least 2, and load the
C     following parameters into RPAR as
C
C      RPAR(1)  = TOLILUT   - Drop tolerance for use by ILUT and ILUTP.
C                             TOLILUT must be .ge. 0.  Larger values
C                             of TOLILUT cause less fill-in.  Good
C                             values range from 0.001 to 0.01.
C      RPAR(2)  = PERMTOL   - Tolerance ratio used in determining column
C                             pivoting by ILUTP.  PERMTOL must be
C                             .ge. 0.  Good values are from 0.1 to
C                             0.01.  Two columns are permuted only if
C                             A(i,j)*PERMTOL .GT. A(i,i).
C
C     The two paramaters TOLILUT and LFILILUT gives the user a great
C     deal of flexibility: one can use TOLILUT=0 to get a strategy
C     based on keeping the largest elements in each row of L and U.
C     Taking TOLILUT .NE. 0 but LFILILUT=NEQ will give the usual
C     threshold strategy (however, fill-in is then unpredictable).
C
C (c) Include the names SJACILU and SPSOLILU in an EXTERNAL statement.
C     Set INFO(15) = 1 to indicate that a JAC routine exists.
C     Then in the call to SDASPK, pass the names SJACILU and SPSOLILU
C     as the arguments JAC and PSOL, respectively.
C
C (d) The SDASPK work arrays RWORK and IWORK must include segments WP
C     and IWP for use by SJACILU/SPSOLILU.  The lengths of these depend
C     on the problem size, half-bandwidths, and other parameters
C     as follows:
C       LWP =  length of RWORK segment WP =
C              2*LENPFAC*NEQ + LENPLUFAC*NEQ + ISRNORM*NEQ + 2*(NEQ+1)
C       LIWP = length of IWORK segment IWP =
C              4*(NEQ+1) + 3*LENPFAC*NEQ + 2*LENPLUFAC*NEQ
C                 + 2*IREORDER*NEQ + 2*(IPREMETH-1)*NEQ
C     Load these lengths in IWORK as
C       IWORK(27) = LWP
C       IWORK(28) = LIWP
C     and include these values in the declared size of RWORK and IWORK.
C
C
C The SJACILU and SPSOLILU routines generate and solve the sparse
C preconditioner matrix P within the preconditioned Krylov algorithm
C used by SDASPK when INFO(12) = 1.  P is generated and ILU-factored
C periodically during the integration, and the factors are used to
C solve systems Px = b as needed.
C-----------------------------------------------------------------------

      SUBROUTINE SSPSETUP (NEQ, LWP, LIWP, RPAR, IPAR, IERR,
     .                     LWP_MIN, LIWP_MIN)

c ... Version of 10-6-95

c ... Calculate storage needed for ILU decomposition of the Jacobian
c     matrix for use as a preconditioner by the SDASPK solver.
c     Also, check for illegal input.

      IMPLICIT NONE

c ... Input arguments:
      INTEGER NEQ      ! total number of equations
      REAL    RPAR(*)  ! user real workspace
      INTEGER IPAR(*)  ! user integer workspace
      INTEGER LWP      ! current length of WP for SDASPK
      INTEGER LIWP     ! current length of IWP for SDASPK

c ... Output arguments:
      INTEGER IERR     ! error flag (0 means success, else failure)
                       ! IERR between 1 and 11, means there's an
                       ! illegal value for IPAR(IERR).
                       ! IERR = 12 means IPAR(29) is illegal.
                       ! IERR = 21 means RPAR(1) is illegal.
                       ! IERR = 22 means RPAR(2) is illegal.
                       ! IERR = 30 means more WP length is needed.
                       ! IERR = 31 means more IWP length is needed.
      INTEGER LWP_MIN  ! minimum WP length needed.
      INTEGER LIWP_MIN ! minimum IWP length needed.

c ... Local variables:
      INTEGER LBW, UBW, LENPLUMX, LJAC, LJACI, LJACJ,
     .        LROWNRMS, LRWK1, LRWK2, LIWK1, LIWK2, LIWK3
      INTEGER LENPFAC, LENPLUFAC, LFILILUT, IPREMETH, NEQP1, NNZMX
      INTEGER LPLU, LJU, LJLU, LPERM, LQPERM, LLEVELS, LMASK
      INTEGER ISRNORM  !=1 causes row normalization of JAC.
      INTEGER NORMTYPE !=0,1,2 for max-norm, 1-norm, or
                       ! 2-norm row scaling
      INTEGER IREORDER !=1 causes row and column reordering of JAC.
      INTEGER JACOUT   !=1 causes the Jacobian matrix and SAVR to
                       !   be written to a file and then exit with
                       !   ierr = 1 to signal a stop to SDASPK.
      INTEGER JSCALCOL !=1 causes the columns of the Jacobian matrix
                       !   to be scaled by EWT-inverse
      REAL   TOLILUT, PERMTOL

c ... Load values from IPAR and RPAR.  Check for illegal values.
      LBW = IPAR(1)          ! LBW must be .gt. 0
      IF (LBW .LE. 0) THEN
         IERR = 1
         RETURN
      ENDIF
      UBW = IPAR(2)          ! UBW must be .gt. 0
      IF (UBW .LE. 0) THEN
         IERR = 2
         RETURN
      ENDIF
      LENPFAC = IPAR(3)      ! LENPFAC must be .ge. 2
      IF (LENPFAC .LE. 1) THEN
         IERR = 3
         RETURN
      ENDIF
      LENPLUFAC = IPAR(4)    ! LENPLUFAC must be .ge. 2
      IF (LENPLUFAC .LE. 1) THEN
         IERR = 4
         RETURN
      ENDIF
      IPREMETH = IPAR(5)     ! IPREMETH must be .eq. 1 or 2 currently
      IF (IPREMETH .NE. 1 .AND. IPREMETH .NE. 2) THEN
         IERR = 5
         RETURN
      ENDIF
      LFILILUT = IPAR(6)     ! LFILILUT must be .ge. 0
      IF (LFILILUT .LT. 0) THEN
         IERR = 6
         RETURN
      ENDIF
      IREORDER = IPAR(7)     ! IREORDER must be 0 or 1
      IF ((IREORDER .LT. 0) .OR. (IREORDER .GT. 1)) THEN
         IERR = 7
         RETURN
      ENDIF
      ISRNORM = IPAR(8)      ! ISRNORM must be 0 or 1
      IF ((ISRNORM .LT. 0) .OR. (ISRNORM .GT. 1)) THEN
         IERR = 8
         RETURN
      ENDIF
      NORMTYPE = IPAR(9)     ! NORMTYPE must be 0, 1, or 2
      IF ((NORMTYPE .LT. 0) .OR. (NORMTYPE .GT. 2)) THEN
         IERR = 9
         RETURN
      ENDIF
      JACOUT = IPAR(10)      ! JACOUT must be 0 or 1
      IF ((JACOUT .LT. 0) .OR. (JACOUT .GT. 1)) THEN
         IERR = 10
         RETURN
      ENDIF
      JSCALCOL = IPAR(11)      ! JSCALCOL must be 0 or 1
      IF ((JSCALCOL .LT. 0) .OR. (JSCALCOL .GT. 1)) THEN
         IERR = 11
         RETURN
      ENDIF
      IF (JACOUT .EQ. 1) THEN ! IPAR(29) must be .gt. 0
         IF (IPAR(29) .LE. 0) THEN
            IERR = 12
            RETURN
         ENDIF
      ENDIF
      TOLILUT = RPAR(1)      ! TOLILUT must be .ge. 0.0
      IF (TOLILUT .LT. 0.) THEN
         IERR = 21
         RETURN
      ENDIF
      IF (IPREMETH .EQ. 2) THEN
         PERMTOL = RPAR(2)      ! PERMTOL must be .ge. 0.0
         IF (PERMTOL .LT. 0.) THEN
            IERR = 22
            RETURN
         ENDIF
      ENDIF

c...  Calculate minimum work lengths for WP and IWP arrays.
      NEQP1 = NEQ + 1
      NNZMX = LENPFAC*NEQ
      LENPLUMX = NNZMX + LENPLUFAC*NEQ
c ... Set up pointers into WP
      LJAC = 1
      LROWNRMS = NNZMX + LJAC
      IF (ISRNORM .EQ. 1) THEN
         LPLU = LROWNRMS + NEQ
      ELSE
         LPLU = LROWNRMS
      ENDIF
      LRWK1 = LPLU + LENPLUMX
      LRWK2 = LRWK1 + NEQP1
      LWP_MIN = LRWK2 + NEQP1 - 1
      IF (LWP .LT. LWP_MIN) THEN
         IERR = 30    ! more WP length needed.
         RETURN
      ENDIF
c ... Set up pointers into IWP
      LJACI = 1
      LJACJ = LJACI + NEQP1
      LJU = LJACJ + NNZMX
      LJLU = LJU + MAX(LENPLUMX,NEQP1)
      IF (IREORDER .NE. 0) THEN
         LPERM = LJLU + LENPLUMX
         LQPERM = LPERM + NEQ
         LIWK1 = LQPERM + NEQ
         LLEVELS = LJLU + NNZMX   ! assumes that LENPLUFAC >= 2.
         LMASK = LLEVELS + NEQ
      ELSE
         LPERM = 0
         LQPERM = 0
         LLEVELS = 0
         LMASK = 0
         LIWK1 = LJLU + LENPLUMX
      ENDIF
      LIWK2 = LIWK1 + NEQP1
      LIWK3 = LIWK2 + NEQP1
      LIWP_MIN = LIWK3 + NEQP1 - 1
      IF (IPREMETH .EQ. 2) LIWP_MIN = LIWP_MIN + 2*NEQ
      IF (LIWP .LT. LIWP_MIN) THEN
         IERR = 31   ! more IWP length needed.
         RETURN
      ENDIF

      IERR = 0
      RETURN
C------------  End of Subroutine SSPSETUP  -----------------------------
      END

      SUBROUTINE SJACILU (RES, IRES, NEQ, T, Y, YPRIME, REWT, SAVR,
     .                    WK, H, CJ, WP, IWP, IERR, RPAR, IPAR)

C ... Version of 10-6-95

C ... Calculate ILU decomposition of the Jacobian matrix
C     for use as a preconditioner by the SDASPK solver.

      IMPLICIT NONE

C ... Input arguments:
      INTEGER NEQ        ! total number of equations
      REAL   T           ! independent variable t
      REAL   Y(NEQ)      ! most recent iterate of solution vector y
      REAL   YPRIME(NEQ) ! most recent iterate of solution vector y'
      REAL   SAVR(NEQ)   ! current residual evaluated at (T,Y,YPRIME)
      REAL   REWT(NEQ)   ! scale factors for Y and YPRIME
      EXTERNAL RES       ! function that evaluates residuals
      INTEGER IRES       ! error flag for RES routine
      REAL   WK(NEQ)     ! work space available to this subroutine
      REAL   H           ! current step size
      REAL   CJ          ! scalar proportional to 1/H
      REAL   RPAR(*)     ! user real workspace
      INTEGER IPAR(*)    ! user integer workspace

C ... Output arguments:
      REAL   WP(*)       ! matrix elements of ILU
      INTEGER IWP(*)     ! array indices for elements of ILU
      INTEGER NRE        ! number of RES calls needed to evaluate
                         ! Jacobian NRE is returned in IPAR(30)
      INTEGER IERR       ! error flag (0 means success, else failure)

C ... Local variables:
      REAL   TOLILUT, PERMTOL, SQRTN
      INTEGER I, LBW, UBW, LENPLUMX, LJAC, LJACI, LJACJ, LIPERM,
     .        LROWNRMS, LRWK1, LRWK2, LIWK1, LIWK2, LIWK3, IFMT
      INTEGER LENPFAC, LENPLUFAC, LFILILUT, IPREMETH, NEQP1, NNZMX
      INTEGER LPLU, LJU, LJLU, LPERM, LQPERM, LLEVELS, LMASK
      INTEGER ISRNORM  !=1 causes row normalization of Jac.
      INTEGER NORMTYPE !=0,1,2 for max-norm, 1-norm, or
                       ! 2-norm row scaling
      INTEGER IREORDER !=1 causes row and column reordering of Jac.
      INTEGER JACOUT   !=1 causes the Jacobian matrix and SAVR to
                       !   be written to a file and then exit with
                       !   IRES = -2 to signal a stop to SDASPK.
      INTEGER IUNIT    ! logical unit number to use when JACOUT .EQ. 1
      INTEGER JSCALCOL !=1 causes the columns of the Jacobian matrix
                       !   to be scaled by REWT-inverse
      CHARACTER*8 PMETH(4), PREMETH
      CHARACTER*72 TITLE
      CHARACTER*80 MSG
      SAVE
      DATA PMETH/'ILUT','ILUTP','ILU0','MILU0'/

C ... Zero out NRE counter
      NRE = 0

C ... Load values from IPAR and RPAR.
      LBW = IPAR(1)
      UBW = IPAR(2)
      LENPFAC = IPAR(3)
      LENPLUFAC = IPAR(4)
      IPREMETH = IPAR(5)
      LFILILUT = IPAR(6)
      IREORDER = IPAR(7)
      ISRNORM = IPAR(8)
      NORMTYPE = IPAR(9)
      JACOUT = IPAR(10)
      JSCALCOL = IPAR(11)
      TOLILUT = RPAR(1)
      PERMTOL = RPAR(2)
      PREMETH = PMETH(IPREMETH)

C...  Set pointers into the WP and IWP arrays.
      NEQP1 = NEQ + 1
      NNZMX = LENPFAC*NEQ
      LENPLUMX = NNZMX + LENPLUFAC*NEQ
C ... Set up pointers into WP
      LJAC = 1
      LROWNRMS = NNZMX + LJAC
      IF (ISRNORM .EQ. 1) THEN
         LPLU = LROWNRMS + NEQ
      ELSE
         LPLU = LROWNRMS
      ENDIF
      LRWK1 = LPLU + LENPLUMX
      LRWK2 = LRWK1 + NEQP1
C ... Set up pointers into IWP
      LJACI = 1
      LJACJ = LJACI + NEQP1
      LJU = LJACJ + NNZMX
      LJLU = LJU + LENPLUMX

C ... Calculate Jacobian matrix.
      IERR = 0
      CALL SJCALC (NEQ, T, Y, YPRIME, SAVR, LBW, UBW, WK, REWT, RES,
     .             H, CJ, NNZMX, WP(LJAC), IWP(LJACJ), IWP(LJACI),
     .             WP(LPLU), IWP(LJLU), IWP(LJU), IPAR, RPAR,
     .             IRES, NRE, IERR)
      IF (IRES .LT. 0) RETURN
      IF (IERR .NE. 0) RETURN

C ... Save NRE value for user output.
      IPAR(30) = IPAR(30) + NRE

C ... Modify pointers into IWP
      LJLU = LJU + NEQP1
      IF (IREORDER .NE. 0) THEN
         LPERM = LJLU + LENPLUMX
         LQPERM = LPERM + NEQ
         LIWK1 = LQPERM + NEQ
         LLEVELS = LJLU + NNZMX   ! assumes that LENPLUFAC >= 2.
         LMASK = LLEVELS + NEQ
      ELSE
         LPERM = 0
         LQPERM = 0
         LLEVELS = 0
         LMASK = 0
         LIWK1 = LJLU + LENPLUMX
      ENDIF
      LIWK2 = LIWK1 + NEQP1
      LIWK3 = LIWK2 + NEQP1
      IF (PREMETH .EQ. 'ILUTP') THEN
         LIPERM = LIWK3 + NEQP1
      ELSE
         LIPERM = LIWK3
      ENDIF
C ... Multiply Jacobian columns by inverse of scaling vector REWT.
C     In PSOLILU, the WGHT array equals REWT/SQRT(NEQ), so we must
C     be consistent here.
      IF (JSCALCOL .EQ. 1) THEN
         SQRTN = SQRT(REAL(NEQ))
         DO 10 I = 1, NEQ
            WK(I) = SQRTN / REWT(I)
 10      CONTINUE
         CALL AMUDIA (NEQ, 0, WP(LJAC), IWP(LJACJ), IWP(LJACI), WK,
     .                WP(LJAC), IWP(LJACJ), IWP(LJACI))
      ENDIF

C ... Normalize Jacobian rows, if desired.
      IF (ISRNORM .EQ. 1) THEN
         CALL ROSCAL (NEQ,0,NORMTYPE,WP(LJAC),IWP(LJACJ),IWP(LJACI),
     .                  WP(LROWNRMS),WP(LJAC),IWP(LJACJ),IWP(LJACI))
      ENDIF

C ... Reorder Jacobian rows and columns, if desired.
      IF (IREORDER .NE. 0) THEN
         CALL SJREORD (NEQ, NEQP1, NNZMX, PREMETH,
     .                 WP(LJAC), IWP(LJACJ), IWP(LJACI),
     .                 WP(LPLU), IWP(LJLU), IWP(LJU),
     .                 IWP(LPERM), IWP(LQPERM), IWP(LLEVELS),
     .                 IWP(LMASK), IREORDER)
      ENDIF

C ... Write matrix JAC and scaled RES to file if JACOUT .eq. 1.
      IF (JACOUT .EQ. 1) THEN
         IUNIT = IPAR(29)
         IF (ISRNORM .EQ. 1) THEN
            DO 20 I = 1, NEQ
               SAVR(I) = SAVR(I) * WP(LROWNRMS+I-1)
 20         CONTINUE
         ENDIF
         IF (IREORDER .NE. 0) CALL DVPERM (NEQ, SAVR, IWP(LPERM))
         TITLE = ' SDASPK Test Matrix '
         IFMT = 15
         CALL PRTMT (NEQ,NEQ,WP(LJAC),IWP(LJACJ),IWP(LJACI),SAVR,
     .        'NN',TITLE,'SPARSKIT','RUA',IFMT,3,IUNIT)
         MSG = 'SJACILU -- Jacobian Matrix written to file.'
         CALL XERRWV(MSG,80,0,0,0,0,0,0,0.0,0.0)
         IERR = 1
         IRES = -2
         RETURN
      ENDIF

C ... Compute ILU decomposition.
      CALL SJILU (NEQ, NEQ+1, NNZMX, WP(LJAC), IWP(LJACJ),
     .            IWP(LJACI), IWP(LJU), WP(LPLU), IWP(LJLU),
     .            WP(LRWK1), WP(LRWK2), IWP(LIWK1),
     .            IWP(LIWK2), IWP(LIWK3), LENPLUMX, TOLILUT,
     .            LFILILUT, PERMTOL, PREMETH, IWP(LIPERM), IERR)
      IF ((IERR .EQ. -2) .OR. (IERR .EQ. -3)) THEN
         IRES = -2  ! Stop since more storage needed.
      ENDIF

C ... Save pointers for use in SPSOLILU into IPAR array.
      IPAR(21) = LPLU
      IPAR(22) = LJU
      IPAR(23) = LJLU
      IPAR(24) = LROWNRMS
      IPAR(25) = LPERM
      IPAR(26) = LQPERM

      RETURN
C------------  End of Subroutine SJACILU  ------------------------------
      END

      SUBROUTINE SJCALC (NEQ, T, Y, YPRIME, R0, ML, MU, R1, REWT, RES,
     .                   H, CJ,  NNZMX, JAC, JA, IA, RCOO, JCOO, ICOO,
     .                   IPAR, RPAR, IRES, NRE, IERR)

c ... Version of 10-6-95

C ... Calculate Jacobian matrix (derivatives with respect to each
C     dependent variable of the right-hand side of each rate equation).
C     Lower and upper bandwidths are used to select for computation
C     only those Jacobian elements that may be nonzero.
C     Estimates of Jacobian elements are computed by finite differences.
C     The Jacobian is stored in compressed sparse row format.

      IMPLICIT NONE

C ... Input arguments:
      INTEGER NEQ        ! total number of equations
      REAL   T           ! independent variable t
      REAL   Y(NEQ)      ! most recent iterate of solution vector y
      REAL   YPRIME(NEQ) ! most recent iterate of solution vector y'
      REAL   R0(NEQ)     ! current residual evaluated at (T,Y,YPRIME)
      REAL   REWT(NEQ)   ! array of scaling factors for Y and YPRIME
      EXTERNAL RES       ! function that evaluates residuals
      INTEGER IRES       ! error flag for RES routine
      INTEGER ML, MU     ! lower and upper bandwidths
      INTEGER NNZMX      ! maximum number of nonzeros in Jacobian
      REAL   H           ! current step size
      REAL   CJ          ! scalar proportional to 1/H
      REAL   RPAR(*)     ! user real workspace
      INTEGER IPAR(*)    ! user integer workspace

C ... Work-array argument:
      REAL   R1(NEQ)   ! work space available to this subroutine

C ... Output arguments:
      REAL   JAC(NNZMX)   ! nonzero Jacobian elements
      INTEGER JA(NNZMX)   ! col indices of nonzero Jacobian elements
      INTEGER IA(NEQ+1)   ! pointers to beginning of each row in JAC,JA
      INTEGER IERR

C ... Workspace for temporary storage of Jacobian elements:
      REAL   RCOO(NNZMX)   ! nonzero Jacobian elements
      INTEGER JCOO(NNZMX)  ! col indices of nonzero Jacobian elements
      INTEGER ICOO(NNZMX)  ! row indices of nonzero Jacobian elements

C ... Local variables:
      INTEGER NNZ, I, I1, I2, J, JJ, MBA, MEBAND, MEB1, MBAND, NRE
      REAL   JACELEM, UROUND, R1MACH, SQUR, DEL, DELINV
      CHARACTER*80 MSG

C ... Set band parameters.
      NNZ = 1
      MBAND = ML + MU + 1
      MBA = MIN0(MBAND,NEQ)
      MEBAND = MBAND + ML
      MEB1 = MEBAND - 1

C ... Set the machine unit roundoff UROUND and SQRT(UROUND), used to
C ... set increments in the difference quotient procedure.
      UROUND = R1MACH(4)
      SQUR = SQRT(UROUND)

C ... Initial error flags.
      IERR = 0
      IRES = 0

C ... Make MBA calls to RES to approximate the Jacobian.
C ... Here, R0(1),...,R0(neq) contains the base RES value, and
C     R1(1),...,R1(NEQ) contains the perturbed values of RES.
      DO 40 J = 1,MBA
        DO 10 JJ = J,NEQ,MBAND
          JAC(JJ) = Y(JJ)
          JAC(JJ+NEQ) = YPRIME(JJ)
          DEL = SQUR*MAX(ABS(Y(JJ)),ABS(H*YPRIME(JJ)),ABS(1.0/REWT(JJ)))
          DEL = SIGN(DEL, H*YPRIME(JJ))
          DEL = (Y(JJ) + DEL) - Y(JJ)
          Y(JJ) = Y(JJ) + DEL
          YPRIME(JJ) = YPRIME(JJ) + CJ*DEL
 10       CONTINUE
        CALL RES (T, Y, YPRIME, CJ, R1, IRES, RPAR, IPAR)
        IF (IRES .LT. 0) RETURN
        NRE = NRE + 1
        DO 30 JJ = J,NEQ,MBAND
          Y(JJ) = JAC(JJ)
          YPRIME(JJ) = JAC(JJ+NEQ)
          DEL = SQUR*MAX(ABS(Y(JJ)),ABS(H*YPRIME(JJ)),ABS(1.0/REWT(JJ)))
          DEL = SIGN(DEL, H*YPRIME(JJ))
          DEL = (Y(JJ) + DEL) - Y(JJ)
          DELINV=1.0/DEL
          I1 = MAX(1,(JJ-MU))
          I2 = MIN(NEQ,(JJ+ML))
          DO 20 I = I1,I2
C ... Calculate possibly nonzero Jacobian elements for this variable,
C     and store nonzero elements in coordinate format.
            JACELEM = (R1(I) - R0(I))*DELINV
            IF (JACELEM .NE. 0.) THEN
               IF (NNZ .GT. NNZMX) THEN
                  MSG = 'SJCALC -- More storage needed for Jacobian.'
                  CALL XERRWV(MSG,80,0,0,0,0,0,0,0.0,0.0)
                  MSG = 'SJCALC -- Increase LENPFAC.'
                  CALL XERRWV(MSG,80,0,0,0,0,0,0,0.0,0.0)
                  MSG = 'SJCALC -- Storage exceeded at (I,J) = (I1,I2)'
                  CALL XERRWV(MSG,80,0,0,2,I,JJ,0,0.0,0.0)
                  IERR = 1
                  IRES = -2
	          RETURN
               ENDIF
               RCOO(NNZ) = JACELEM
               JCOO(NNZ) = JJ
               ICOO(NNZ) = I
               NNZ = NNZ + 1
            ENDIF
 20         CONTINUE
 30       CONTINUE
 40    CONTINUE
      NNZ = NNZ - 1
C
C ... Convert Jacobian from coordinate to compressed sparse row format.
      CALL COOCSR (NEQ, NNZ, RCOO, ICOO, JCOO, JAC, JA, IA)

      RETURN
C------------  End of Subroutine SJCALC  -------------------------------
      END

      SUBROUTINE SPSOLILU (NEQ, T, Y, YPRIME, R0, WK, CJ, WGHT,
     .                     WP, IWP, BL, EPLIN, IERR, RPAR, IPAR)

c ... Version of 10-6-95

C ... Solve the linear system P*x=c, using elements of P loaded into
C     arrays WP and IWP.
C

      IMPLICIT NONE

C ... Input arguments:
      INTEGER NEQ        ! total number of equations
      REAL   T           ! independent variable t
      REAL   Y(NEQ)      ! most recent iterate of solution vector y
      REAL   YPRIME(NEQ) ! most recent iterate of solution vector y'
      REAL   R0(NEQ)     ! function value G(T,Y,YPRIME)
      REAL   WGHT(NEQ)   ! scaling array for Y and YPRIME
      REAL   CJ          ! scalar proportional to 1/H
      REAL   EPLIN       ! not used
      REAL   WP(*)       ! matrix elements of ILU
      INTEGER IWP(*)     ! array indices for elements of ILU
      INTEGER IPAR(*)    ! user workspace
      REAL   RPAR(*)     ! user workspace

C ... Work-array argument:
      REAL   WK(NEQ)     ! work space available to this subroutine

C ... In-out argument:
      REAL   BL(NEQ)     ! on input, c of P*x=c; on output, x

C ... Output arguments:
      INTEGER IERR     ! error flag (0 only possible value here)

C ... Local variables:
      INTEGER I, LPLU, LJU, LJLU, LROWNRMS, LPERM, LQPERM, IREORDER,
     .        ISRNORM, IPREMETH, JSCALCOL

C ... Load IPREMETH, IREORDER and ISRNORM values from IPAR.
      IPREMETH = IPAR(5)
      IREORDER = IPAR(7)
      ISRNORM = IPAR(8)
      JSCALCOL = IPAR(11)

C ... Load pointers into WP and iWP arrays.
      LPLU = IPAR(21)
      LJU  = IPAR(22)
      LJLU = IPAR(23)
      LROWNRMS = IPAR(24)
      LPERM = IPAR(25)
      LQPERM = IPAR(26)

C ... Scale c by multiplying by row-normalization factors, if used.
      IF (ISRNORM .EQ. 1) THEN
         DO 10 I = 1, NEQ
            BL(I) = BL(I) * WP(LROWNRMS+I-1)
 10      CONTINUE
      ENDIF

C ... Solve P*x=c for a preconditioner stored as a sparse matrix in
C     compressed sparse row format.
C     If rows and columns of P were reordered (permuted), permute c,
C     then use inverse permutation on x.
      IF (IPREMETH .EQ. 1 .OR. IPREMETH .EQ. 2) THEN
	 IF (IREORDER .EQ. 1) CALL DVPERM (NEQ, BL, IWP(LPERM))
         CALL LUSOL0 (NEQ, BL, WK, WP(LPLU), IWP(LJLU), IWP(LJU))
	 IF (IREORDER .EQ. 1) CALL DVPERM (NEQ, WK, IWP(LQPERM))
      ENDIF

C ... Unscale x by dividing by column scaling vector WGHT.
      IF (JSCALCOL .EQ. 1) THEN
         DO 40 I = 1,NEQ
            BL(I) = WK(I) / WGHT(I)
 40      CONTINUE
      ENDIF

      IERR = 0
      RETURN
C------------  End of Subroutine SPSOLILU  -----------------------------
      END

      SUBROUTINE SJILU (NEQ, NEQP1, NNZMX, JAC, JA, IA, JU,
     .                  PLU, JLU, RWK1, RWK2, IWK1, IWK2, IWK3,
     .                  LENPLUMX, TOLILUT, LFILILUT, PERMTOL, PREMETH,
     .                  IPERM, IERR)

c ... Version of 10-6-95

C ... Compute ILU decomposition of Jacobian and return it in any one
C     of the storage formats.

      IMPLICIT NONE

C ... Input arguments:
      INTEGER NEQ        ! total number of equations
      INTEGER NEQP1      ! NEQ + 1
      INTEGER NNZMX      ! maximum number of nonzeros in Jacobian
      REAL   JAC(NNZMX)  ! nonzero Jacobian elements
      INTEGER JA(NNZMX)  ! col indices of nonzero Jacobian elements
      INTEGER IA(NEQP1)  ! pointers to beginning of each row in jac,ja
      CHARACTER*8 PREMETH
      REAL   TOLILUT
      REAL   PERMTOL
      INTEGER LENPLUMX
      INTEGER LFILILUT
      REAL   RWK1(NEQP1), RWK2(NEQP1)
      INTEGER IWK1(NEQP1), IWK2(NEQP1), IWK3(NEQP1), IPERM(2*NEQ)

C ... Output arguments:
      REAL   PLU(LENPLUMX) ! matrix elements of ILU
      INTEGER JLU(LENPLUMX)! sizes and array indices for elements of ILU
      INTEGER JU(NEQ)      ! pointer to beginning of each row of U in
                           ! matrix PLU,JLU
      INTEGER IERR         ! error flag

C ... Local variables:
      CHARACTER*80 MSG
      LOGICAL ERROR

      ERROR = .FALSE.

      IF (PREMETH .EQ. 'ILUT') THEN

C ... Use incomplete factorization routine ILUT from SparsKit.
         CALL ILUT (NEQ,JAC,JA,IA,LFILILUT,TOLILUT,PLU,JLU,
     .              JU,LENPLUMX,RWK1,RWK2,IWK1,
     .              IWK2,IWK3,IERR)
         IF (IERR .NE. 0) THEN
            MSG = 'SJILU -- Error return from ILUT: IERR = (I1)'
            CALL XERRWV(MSG,80,0,0,1,IERR,0,0,0.0,0.0)
            ERROR = .TRUE.
         ENDIF

      ELSEIF (PREMETH .EQ. 'ILUTP') then

C ... Use incomplete factorization routine ILUTP from SparsKit.
         CALL ILUTP (NEQ,JAC,JA,IA,LFILILUT,TOLILUT,PERMTOL,NEQ,
     .               PLU,JLU,JU,LENPLUMX,RWK1,RWK2,IWK1,IWK2,IWK3,
     .               IPERM,IERR)
         IF (IERR .NE. 0) THEN
            MSG = 'SJILU -- Error return from ILUTP: IERR = (I1)'
            CALL XERRWV(MSG,80,0,0,1,IERR,0,0,0.0,0.0)
            ERROR = .TRUE.
         ENDIF

C ... Put in other options here for incomplete factorizations.
      ENDIF

      IF(ERROR) THEN
         MSG =
     . 'SJILU -- IERR .NE. 0 means one of the following has occurred:'
         CALL XERRWV(MSG,80,0,0,0,0,0,0,0.0,0.0)
         MSG =
     . '    IERR >  0   --> Zero pivot encountered at step number IERR.'
         CALL XERRWV(MSG,80,0,0,0,0,0,0,0.0,0.0)
         MSG =
     . '    IERR = -1   --> Error. input matrix may be wrong.'
         CALL XERRWV(MSG,80,0,0,0,0,0,0,0.0,0.0)
         MSG =
     . '                     (The elimination process has generated a'
         CALL XERRWV(MSG,80,0,0,0,0,0,0,0.0,0.0)
         MSG =
     . '                     row in L or U with length > NEQ.)'
         CALL XERRWV(MSG,80,0,0,0,0,0,0,0.0,0.0)
         MSG ='    IERR = -2   --> Matrix L overflows.'
         CALL XERRWV(MSG,80,0,0,0,0,0,0,0.0,0.0)
         MSG ='    IERR = -3   --> Matrix U overflows.'
         CALL XERRWV(MSG,80,0,0,0,0,0,0,0.0,0.0)
         MSG ='    IERR = -4   --> Illegal value for LFILILUT.'
         CALL XERRWV(MSG,80,0,0,0,0,0,0,0.0,0.0)
         MSG ='    IERR = -5   --> Zero row encountered.'
         CALL XERRWV(MSG,80,0,0,0,0,0,0,0.0,0.0)
         MSG ='    '
         CALL XERRWV(MSG,80,0,0,0,0,0,0,0.0,0.0)
         MSG =
     . '    For IERR = -2 or -3, increase the value of LENPLUFAC or'
         CALL XERRWV(MSG,80,0,0,0,0,0,0,0.0,0.0)
         MSG =
     . '    decrease the value of LFILILUT if LENPLUFAC cannot be'
         CALL XERRWV(MSG,80,0,0,0,0,0,0,0.0,0.0)
         MSG ='    increased.'
         CALL XERRWV(MSG,80,0,0,0,0,0,0,0.0,0.0)
      ENDIF

      RETURN
C------------  End of Subroutine SJILU  --------------------------------
      END

      SUBROUTINE SJREORD (NEQ, NEQP1, NNZMX, PREMETH,
     .                    JAC, JA, IA, AWK, JWK, IWK,
     .                    PERM, QPERM, LEVELS, MASK, IREORDER)

c ... Version of 10-6-95

C ... If desired, reorder the Jacobian matrix.

      IMPLICIT NONE

C ... Input arguments:
      INTEGER NEQ        ! total number of equations
      INTEGER NEQP1      ! NEQ + 1
      INTEGER NNZMX      ! maximum number of nonzeroes in Jacobian
      REAL   JAC(NNZMX)  ! nonzero Jacobian elements
      INTEGER JA(NNZMX)  ! column indices of nonzero Jacobian elements
      INTEGER IA(NEQP1)  ! indices of 1st nonzero element in each row
      CHARACTER*8 PREMETH

C ... Work-array arguments:
      REAL   AWK(NNZMX)
      INTEGER JWK(NNZMX)
      INTEGER IWK(NEQP1)
      INTEGER PERM(NEQ)   ! Integer array containing the permutation
                          ! used in reordering the rows and columns of
			  ! the Jacobian matrix.
      INTEGER QPERM(NEQ)  ! Integer array holding the inverse of the
			  ! permutation in array perm.
      INTEGER LEVELS(NEQ) ! Work array used by the bfs reordering
			  ! subroutine.   See subroutine BFS for
			  ! more details.
      INTEGER MASK(NEQ)	  ! Work array used by the BFS reordering
			  ! subroutine.  See BFS subroutine.
      INTEGER IREORDER    ! Flag used to determine if a reordering
			  ! of the Jacobian matrix is desired.
			  ! = 1 means a reverse Cuthill-McKee
			  !     reordering of the rows and columns
			  !     of the Jacobian is done.
			  ! = 0 means no reordering.

C ... Local variables:
      INTEGER NLEV	  ! Number of levels in levels array.
			  ! See subroutine BFS for more details.
      INTEGER MASKVAL	  ! Scalar used with MASK.
      INTEGER I, NFIRST

      IF (IREORDER .EQ. 1) THEN

C ... Copy JAC, JA, and IA to AWK, JWK, and IWK.
         CALL ATOB (NEQ, JAC, JA, IA, AWK, JWK, IWK)

C ... Perform a Cuthill-McKee reordering of the Jacobian.
         NFIRST = 1
         PERM(1) = 0
         DO I = 1, NEQ
            MASK(I) = 1
         ENDDO
         MASKVAL = 1
         QPERM(1) = 1
         CALL BFS (NEQ,JWK,IWK,NFIRST,PERM,MASK,MASKVAL,QPERM,LEVELS,
     .             NLEV)

C ... Reverse the permutation to obtain the reverse Cuthill-McKee
C     reordering.
         CALL REVERSP (NEQ,QPERM)

C ... Calculate the inverse of QPERM and put it in PERM.
         DO I = 1, NEQ
            PERM(QPERM(I)) = I
         ENDDO

C ... Permute rows and columns of Jacobian using PERM.
         CALL DPERM (NEQ,AWK,JWK,IWK,JAC,JA,IA,PERM,PERM,1)

C ... End of If block
      ENDIF

      RETURN
C------------  End of Subroutine SJREORD  ------------------------------
      END


program test_point_in_on

    use geo, only : point_is_on_line, point_in_poly
    implicit none

    real :: x,y
    real :: poly(2,4), large_poly(2,8), triangle(2,3)
    real :: x0,y0,x1,y1
    integer :: i,j

    logical :: passing
    passing=.True.

    x0=0; y0=0; x1=1; y1=1
    x=0.5; y=0.5
    if (point_is_on_line(x,y,x0,y0,x1,y1)) then
        print*, "Correctly identified ",x, y, "on line."
    else
        passing=.false.
        print*, "Point_is_on_line Failed", x, y
    endif

    x=0.6; y=0.5
    if (point_is_on_line(x,y,x0,y0,x1,y1)) then
        print*, "Point_is_on_line Failed", x, y
        passing=.false.
    else
        print*, "Correctly identified ",x, y, "off line."
    endif

    x = 35.4495850
    y = 34.0271034
    print*, "Testing problem grid cell from a simulation."
    print*, "[",x,",", y,"]"
    print*, ""

    ! These are the coordinates of the bounding box of grid cells for which find_surrounding was failing before
    ! poly(1,:) = [35.40149, 35.46729, 35.40778, 35.47363]
    ! poly(2,:) = [33.99421, 33.98899, 34.04877, 34.04354]

    triangle(1,:) = [35.4077759, 35.4736328, 35.4375458]
    triangle(2,:) = [34.0487747, 34.0435371, 34.0188789]

    passing = passing.and.test_poly(x,y,triangle,.True.)

    ! Note that this will actually fail because the precision is "too" high,
    ! but if the points are in a different order it will fail for the other viable set as well! 1e-7 is too high a precision for lat/lon as single precision reals
    !
    ! print*, point_in_poly(x,y,triangle, precision=1e-7)
    ! result = .False. ^^^^

    poly(1,:) = [0,0,1,1]
    poly(2,:) = [0,1,1,0]

    x=0.5; y=0.5
    passing = passing.and.test_poly(x,y,poly,.True.)

    x=1.01; y=0.5
    passing = passing.and.test_poly(x,y,poly,.False.)

    poly(1,:) = [0.5,0.0,0.5,1.0]
    poly(2,:) = [0.0,0.5,1.0,0.5]

    print*, "Testing diamond polygon edge cases"
    print*, " x = polygon vertex "
    print*, " o = test point     "
    print*, ""

    x=0.5; y=0.5
    print*, ""
    print*, "Testing: ", x, y
    print*, "          x      "
    print*, "         / \     "
    print*, "        /   \    "
    print*, "       x  o  x   "
    print*, "        \   /    "
    print*, "         \ /     "
    print*, "          x      "
    passing = passing.and.test_poly(x,y,poly,.True.)

    x=-0.1; y=0.5
    print*, ""
    print*, "Testing: ", x, y
    print*, "          x      "
    print*, "         / \     "
    print*, "        /   \    "
    print*, "   o   x     x   "
    print*, "        \   /    "
    print*, "         \ /     "
    print*, "          x      "
    passing = passing.and.test_poly(x,y,poly,.False.)

    x=0.1; y=0.0
    print*, ""
    print*, "Testing: ", x, y
    print*, "          x      "
    print*, "         / \     "
    print*, "        /   \    "
    print*, "       x     x   "
    print*, "        \   /    "
    print*, "         \ /     "
    print*, "   o      x      "
    passing = passing.and.test_poly(x,y,poly,.False.)

    x=0.51; y=0.51
    print*, ""
    print*, "Testing: ", x, y
    print*, "          x      "
    print*, "         / \     "
    print*, "        / o \    "
    print*, "       x     x   "
    print*, "        \   /    "
    print*, "         \ /     "
    print*, "          x      "
    passing = passing.and.test_poly(x,y,poly,.True.)

    x=0.25; y=0.25
    print*, ""
    print*, "Testing: ", x, y
    print*, "          x      "
    print*, "         / \     "
    print*, "        /   \    "
    print*, "       x     x   "
    print*, "        \   /    "
    print*, "         o /     "
    print*, "          x      "
    passing = passing.and.test_poly(x,y,poly,.True.)

    x=0.2; y=0.25
    print*, ""
    print*, "Testing: ", x, y
    print*, "          x      "
    print*, "         / \     "
    print*, "        /   \    "
    print*, "       x     x   "
    print*, "        \   /    "
    print*, "        o\ /     "
    print*, "          x      "
    passing = passing.and.test_poly(x,y,poly,.False.)

    x=0.9; y=0.25
    print*, ""
    print*, "Testing: ", x, y
    print*, "          x      "
    print*, "         / \     "
    print*, "        /   \    "
    print*, "       x     x   "
    print*, "        \   /    "
    print*, "         \ / o   "
    print*, "          x      "
    passing = passing.and.test_poly(x,y,poly,.False.)

    x=0.2; y=0.75
    print*, ""
    print*, "Testing: ", x, y
    print*, "          x      "
    print*, "        o/ \     "
    print*, "        /   \    "
    print*, "       x     x   "
    print*, "        \   /    "
    print*, "         \ /     "
    print*, "          x      "
    passing = passing.and.test_poly(x,y,poly,.False.)

    x=0.25; y=0.75
    print*, ""
    print*, "Testing: ", x, y
    print*, "          x      "
    print*, "         o \     "
    print*, "        /   \    "
    print*, "       x     x   "
    print*, "        \   /    "
    print*, "         \ /     "
    print*, "          x      "
    passing = passing.and.test_poly(x,y,poly,.True.)

    print*, "Testing larger polygon edge cases"
    large_poly(1,:) = [0.0, 0.0, 1.0, 1.0, 0.75, 0.75, 0.25, 0.25]
    large_poly(2,:) = [0.0, 1.0, 1.0, 0.0, 0.00, 0.50, 0.50, 0.00]

    x=0.25; y=0.5
    print*, ""
    print*, "Testing: ", x, y
    print*, "  x-------------x"
    print*, "  |             |"
    print*, "  |  o x---x    |"
    print*, "  |    |   |    |"
    print*, "  x----x   x----x"
    passing = passing.and.test_poly(x,y,large_poly,.True.)

    print*, ""
    large_poly(1,:) = [0.0, 0.0, 1.0, 1.0,  0.75, 0.75, 0.25, 0.25]
    large_poly(2,:) = [0.0, 1.0, 1.0, 0.75, 0.75, 0.50, 0.50, 0.00]

    x=0.25; y=0.5
    print*, ""
    print*, "Testing: ", x, y
    print*, "  x--------------x"
    print*, "  |              |"
    print*, "  |         x----x"
    print*, "  |  o x----x     "
    print*, "  |    |          "
    print*, "  |    |          "
    print*, "  x----x          "

    passing = passing.and.test_poly(x,y,large_poly,.True.)

    large_poly(1,1:3) = [281.6548,281.7756,281.9876]
    large_poly(2,1:3) = [34.91632, 35.36251,35.08936]

    x=281.98; y=35.0
    print*, ""
    print*, "Testing: ", x, y
    print*, "  x-----x"
    print*, "  |    / "
    print*, "  |   /o "
    print*, "  |  /   "
    print*, "  | /    "
    print*, "  |/     "
    print*, "  x      "
    passing = passing.and.test_poly(x,y,large_poly(:,1:3),.False.)

    large_poly(1,1:3) = [281.6548,282.1,281.9876]
    large_poly(2,1:3) = [34.91632, 34.8,35.08936]

    x=281.98; y=35.0
    print*, ""
    print*, "Testing: ", x, y
    print*, "        x "
    print*, "       /| "
    print*, "      /o| "
    print*, "     /  | "
    print*, "    /   | "
    print*, "   /    | "
    print*, "  x-----x"
    passing = passing.and.test_poly(x,y,large_poly(:,1:3),.True.)

    large_poly(1,1:3) =[290.0750,289.8967,289.7062]
    large_poly(2,1:3) =[38.79078,38.35439,38.64164]
    x=289.9; y=38.72
    print*, ""
    print*, "Testing: ", x, y
    print*, "        x "
    print*, "       /| "
    print*, "      o | "
    print*, "     /  | "
    print*, "    /   | "
    print*, "   /    | "
    print*, "  x-----x"
    passing = passing.and.test_poly(x,y,large_poly(:,1:3),.True.)

    print*, ""
    print*, "Final Result:"
    if (passing) then
        print*, "Passed"
    else
        print*, "Failed"
    endif

contains

    function test_poly(x,y,poly, expected) result(passed)
        implicit none
        real,       intent(in) :: x,y
        real,       intent(in) :: poly(:,:)
        logical,    intent(in) :: expected
        logical :: passed

        if (point_in_poly(x,y,poly) .eqv. expected) then
            passed=.True.
        else
            passed=.False.
            print*, "point_in_poly Failed for:"
            print*, " x=",x,"    y=",y
            print*, "Polygon x vertices:"
            print*, poly(1,:)
            print*, "Polygon y vertices:"
            print*, poly(2,:)
        endif

    end function test_poly

end program test_point_in_on


program Relational_Operation
    implicit none
    real :: a = 4.0, b = 2.0

    !Method One
    print *, "a ==b ::", a == b
    print *, "a > b ::", a > b
    print *, "a >= b :: ", a >= b
    print *, "a < b ::", a < b
    print *, "a <= b :: ", a <= b
    print *, "a /n b :: ", a /= b

    !Method Two
    print *, "a ==b :: ", a .eq. b
    print *, "a > b :: ", a .gt. b
    print *, "a >= b :: ", a .ge. b
    print *, "a < b :: ", a .lt. b
    print *, "a <= b :: ", a .lt. b
    print *, "a /n b :: ", a .ne. b

end program Relational_Operation


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   fhn : Homoclinic bifurcations in Fitz-Hugh Nagumo System
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      F(1)= U(2)
      F(2)= PAR(1)*U(2)+U(1)*(U(1)-PAR(2))*(U(1)-1)+U(3)
      F(3)= PAR(3)*U(1)/PAR(1)

      IF(IJAC.EQ.0)RETURN

      DFDU(1,1)= 0
      DFDU(1,2)= 1
      DFDU(1,3)= 0

      DFDU(2,1)= 3*U(1)*U(1)-2*(1+PAR(2))*U(1)+PAR(2)
      DFDU(2,2)= PAR(1)
      DFDU(2,3)= 1

      DFDU(3,1)= PAR(3)/PAR(1)
      DFDU(3,2)= 0
      DFDU(3,3)= 0

      IF(IJAC.EQ.1)RETURN

      DFDP(1,1)= 0
      DFDP(1,2)= 0
      DFDP(1,3)= 0

      DFDP(2,1)= U(2)
      DFDP(2,2)= -U(1)*(U(1)-1)
      DFDP(2,3)= 0

      DFDP(3,1)= -PAR(3)*U(1)/PAR(1)**2
      DFDP(3,2)= 0
      DFDP(3,3)= U(1)/PAR(1)

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ----------------

! Sets parameter values for homoclinic bifurcation analysis (IPS=9).

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T
!
! COMMON block needed if IPS=9 (homoclinic bifurcations) :
      INTEGER ITWIST,ISTART,IEQUIB,NFIXED,NPSI,NUNSTAB,NSTAB,NREV
      COMMON /BLHOM/ ITWIST,ISTART,IEQUIB,NFIXED,NPSI,NUNSTAB,NSTAB,NREV

!----------------------------------------------------------------------
! Problem parameters (only PAR(1-9) are available to the user) :

        PAR(1) = 0.21         ! c
        PAR(2) = 0.2         ! a
        PAR(3) = 0.0025      ! b = epsilon

        PAR(11)=  0.1            ! truncated time interval
!----------------------------------------------------------------------
! If IEQUIB=1 then put the equilibrium in PAR(11+i), i=1,...,NDIM :

        IF (IEQUIB.NE.0) THEN
          PAR(12) = 0.0
          PAR(13) = 0.0
          PAR(14) = 0.0
        ENDIF
!----------------------------------------------------------------------
! Distance along the unstable manifold :

        IF (ISTART.EQ.3) THEN
          PAR(12+NDIM*IEQUIB)=0.00001
        ENDIF
!----------------------------------------------------------------------

      END SUBROUTINE STPNT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C---------F  E  M   U  T  I  L  I  T  I  E  S   B  L  O  C  K----------C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE GSTFASEM                                              C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE GSTFASEM(NUMNP,NUMEL,NUMAT,NNE,NMNE,MXDOFEL,IELT,
     1                    IELCON,NDOFN,NDOFEL,MATP,NMATP,NMPR,
     2                    MCRD,AMATE,COORD,LM,NEQ,SKG,SMG,IATYPE,IOUT)

C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      ALLOCATABLE SK(:,:),SM(:,:),PROPS(:)
C
      PARAMETER (ZERO=0.D0)
C
C     INTEGER ARRAYS
C
      DIMENSION NNE(NUMEL),IELT(NUMEL),IELCON(NMNE,NUMEL),MATP(NUMEL),
     1          LM(NUMEL,MXDOFEL),LML(MXDOFEL),NDOFN(NUMNP),
     2          NDOFEL(NUMEL),NMATP(NUMAT),AMATE(NMPR,NUMAT),
     3          COORD(MCRD,NUMNP),ELCOOR(MCRD,NMNE),SKG(NEQ,NEQ),
     4          SMG(NEQ,NEQ)
C
      CALL CLEAR(SKG,NEQ,NEQ)
      CALL CLEAR(SMG,NEQ,NEQ)
      CALL CLEARIV(LML,MXDOFEL)
C
C     RETRIEVES ELEMENT MATERIAL PROPERTIES
C
      DO I=1,NUMEL
C
        ND=NDOFEL(I)
        NPROPS=NMATP(MATP(I))
        ALLOCATE(PROPS(NPROPS),SK(ND,ND),SM(ND,ND))
        CALL CLEAR(SK,ND,ND)
        CALL CLEAR(SM,ND,ND)
C
        DO K1=1,NPROPS
          PROPS(K1)=AMATE(K1,MATP(I))
        END DO
C
C       RETRIEVES ELEMENT NODAL COORDINATES
C       ASSEMBLY LIST
C
        K3=0
        DO J=1,NNE(I)
          K1=NDOFN(IELCON(J,I))
          DO JJ=1,MCRD
            ELCOOR(JJ,J)=COORD(JJ,IELCON(J,I))
          END DO
          DO K2=1,K1
            LML(K3+K2)=LM(I,K3+K2)
          END DO
          K3=K3+K1
        END DO

C
C       CALLS EMBEDED USER ELEMENT SUBROUTINE UEL ACCORDING TO IELT(I)
C               IELT()=1 8 NODED QUAD.
C
        SELECT CASE (IELT(I))
C
          CASE (1)
          CALL UEL_FEM8(SK,SM,ND,PROPS,NPROPS,ELCOOR,MCRD,NNE(I),I)
          CASE (2)
          CALL UEL_FEM9(SK,SM,ND,PROPS,NPROPS,ELCOOR,MCRD,NNE(I),I)
          CASE (3)
          CALL UEL_COS8(SK,SM,ND,PROPS,NPROPS,ELCOOR,MCRD,NNE(I),I)
C
        END SELECT
C
C       ASSEMBLE GLOBAL STIFFNESS AND MASS MATRICES
C
        DO II=1,ND
          KK=LML(II)
          IF(KK.NE.0) THEN
             DO JJ=1,ND
               LL=LML(JJ)
               IF(LL.NE.0) THEN
                 SKG(KK,LL)=SKG(KK,LL)+SK(II,JJ)
                 SMG(KK,LL)=SMG(KK,LL)+SM(II,JJ)
               END IF
             END DO
           END IF
        END DO
        DEALLOCATE(PROPS,SK,SM)
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE ASSEMLIS                                              C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE ASSEMLIS(NUMNP,NUMEL,MXNE,MXDOFEL,MXDOFDIM,NNE,NDOFN,
     1                    IELCON,LM,ID,IIN,IOUT)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION NNE(NUMEL),IELCON(MXNE,NUMEL),LM(NUMEL,MXDOFEL),
     1          ID(MXDOFDIM,NUMNP),NDOFN(NUMNP)
C
      DO I=1,NUMEL
        K3=0
        DO J=1,NNE(I)
          K2I=NDOFN(IELCON(J,I))
          DO K2=1,K2I
            LM(I,K3+K2)=ID(K2,IELCON(J,I))
          END DO
          K3=K3+K2I
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C11111111122222222223333333333444444444455555555556666666666777777777777
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C         --G E N E R A L  F E M  S U B R O U T I N E S--              C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C STRAIN DISPLACEMENT INTERPOLATORS                                    C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE STDM9:GENERATES THE STRAIN-DISPLACEMENT MATRIX B      C
C     AND JACOBIAN DETERMINANT DDET AT THE POINT r ,s                  C
C                                                 i  j                 C
C     FOR AN 9-NODED 2D ELEMENT-PLANE STRAIN                           C
C     B    =STRAIN-DISPLACEMENT MATRIX                                 C
C     DDET =JACOBIAN DETERMINANT                                       C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE STDM9(IDEL,NNE,NDOFEL,NTENS,XX,B,DDET,R,S,XBAR)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (ONE=1.D0,TWO=2.D0,THREE=3.D0,HALF=0.5D0)
C
      DIMENSION XX(2,NNE),B(NTENS,NDOFEL),P(2,NNE),AUX1(2,NNE),XJ(2,2),
     2          XJI(2,2)
C
C     Initialize arrays
C
      XBAR=ONE
      CALL CLEAR(B,NTENS,NDOFEL)
      CALL CLEAR(XJ,2,2)
      CALL CLEAR(XJI,2,2)
      CALL CLEAR(P,2,NNE)
C
C     Shape functions derivatives w.r.t natural coordinates
C
      CALL SFDER9(IELT,NDOFEL,NNE,R,S,P)
C
C     Computes the Jacobian operator and its determinant at point (r,s)
C
      CALL JACOPER(NNE,XJ,XX,P)
      DDET=XJ(1,1)*XJ(2,2)-XJ(1,2)*XJ(2,1)
C
C     Computes the inverse of the Jacobiam operator
C
      CALL JACINVE(XJ,DDET,XJI)
C
C     Jacobian Inverse times Shape Functions derivatives w.r.t natural coordinates
C     to produce shape function derivatives w.r.t x,y coordinates.
C
      CALL MMULT(XJI,2,2,P,2,NNE,AUX1)
C
C     Assembles B matrix for a
C     Cosserat element.
C
      DO I=1,NNE
        II=2*(I-1)+1
        B(1,II)=AUX1(1,I)
        B(2,II+1)=AUX1(2,I)
        B(4,II)=AUX1(2,I)
        B(4,II+1)=AUX1(1,I)
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE STDM8:GENERATES THE STRAIN-DISPLACEMENT MATRIX B      C
C     AND JACOBIAN DETERMINANT DDET AT THE POINT r ,s                  C
C                                                 i  j                 C
C     FOR AN 8-NODED 2D ELEMENT-PLANE STRAIN                           C
C     B    =STRAIN-DISPLACEMENT MATRIX                                 C
C     DDET =JACOBIAN DETERMINANT                                       C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE STDM8(IDEL,NNE,NDOFEL,NTENS,XX,B,DDET,R,S,XBAR)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (ONE=1.D0,TWO=2.D0,THREE=3.D0,HALF=0.5D0)
C
      DIMENSION XX(2,NNE),B(NTENS,NDOFEL),P(2,NNE),AUX1(2,NNE),XJ(2,2),
     2          XJI(2,2)
C
C     Initialize arrays
C
      XBAR=ONE
      CALL CLEAR(B,NTENS,NDOFEL)
      CALL CLEAR(XJ,2,2)
      CALL CLEAR(XJI,2,2)
      CALL CLEAR(P,2,NNE)
C
C     Shape functions derivatives w.r.t natural coordinates
C
      CALL SFDER8(IELT,NDOFEL,NNE,R,S,P)
C
C     Computes the Jacobian operator and its determinant at point (r,s)
C
      CALL JACOPER(NNE,XJ,XX,P)
      DDET=XJ(1,1)*XJ(2,2)-XJ(1,2)*XJ(2,1)
C
C     Computes the inverse of the Jacobiam operator
C
      CALL JACINVE(XJ,DDET,XJI)
C
C     Jacobian Inverse times Shape Functions derivatives w.r.t natural coordinates
C     to produce shape function derivatives w.r.t x,y coordinates.
C
      CALL MMULT(XJI,2,2,P,2,NNE,AUX1)
C
C     Assembles B matrix for a
C     Cosserat element.
C
      DO I=1,NNE
        II=2*(I-1)+1
        B(1,II)=AUX1(1,I)
        B(2,II+1)=AUX1(2,I)
        B(4,II)=AUX1(2,I)
        B(4,II+1)=AUX1(1,I)
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE STDM6:GENERATES THE STRAIN-DISPLACEMENT MATRIX B      C
C     AND JACOBIAN DETERMINANT DDET AT THE POINT r ,s                  C
C                                                 i  j                 C
C     FOR AN 6-NODED 2D ELEMENT-PLANE STRAIN                           C
C     B    =STRAIN-DISPLACEMENT MATRIX                                 C
C     DDET =JACOBIAN DETERMINANT                                       C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE STDM6(IDEL,NNE,NDOFEL,NTENS,XX,B,DDET,R,S,XBAR)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (ONE=1.D0,TWO=2.D0,THREE=3.D0,HALF=0.5D0)
C
      DIMENSION XX(2,NNE),B(NTENS,NDOFEL),P(2,NNE),AUX1(2,NNE),XJ(2,2),
     2          XJI(2,2)
C
C     Initialize arrays
C
      XBAR=ONE
      CALL CLEAR(B,NTENS,NDOFEL)
      CALL CLEAR(XJ,2,2)
      CALL CLEAR(XJI,2,2)
      CALL CLEAR(P,2,NNE)
C
C     Shape functions derivatives w.r.t natural coordinates
C
      CALL SFDER6(IELT,NDOFEL,NNE,R,S,P)
C
C     Computes the Jacobian operator and its determinant at point (r,s)
C
      CALL JACOPER(NNE,XJ,XX,P)
      DDET=XJ(1,1)*XJ(2,2)-XJ(1,2)*XJ(2,1)
C
C     Computes the inverse of the Jacobiam operator
C
      CALL JACINVE(XJ,DDET,XJI)
C
C     Jacobian Inverse times Shape Functions derivatives w.r.t natural coordinates
C     to produce shape function derivatives w.r.t x,y coordinates.
C
      CALL MMULT(XJI,2,2,P,2,NNE,AUX1)
C
C     Assembles B matrix for a
C     Cosserat element.
C
      DO I=1,NNE
        II=2*(I-1)+1
        B(1,II)=AUX1(1,I)
        B(2,II+1)=AUX1(2,I)
        B(4,II)=AUX1(2,I)
        B(4,II+1)=AUX1(1,I)
      END DO
C
      RETURN
C
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE STDM8C:GENERATES THE STRAIN-DISPLACEMENT MATRIX B   C
C     AND JACOBIAN DETERMINANT DDET AT THE POINT r ,s                  C
C                                                 i  j                 C
C     FOR AN 8-NODED 2D ELEMENT-PLANE STRAIN FULL COSSERAT ELEMENT     C
C     B    =STRAIN-DISPLACEMENT MATRIX                                 C
C     DDET =JACOBIAN DETERMINANT                                       C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE STDM8C(IDEL,NNE,NDOFEL,NTENS,XX,B,DDET,R,S,XBAR)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (ONE=1.D0,TWO=2.D0,THREE=3.D0,HALF=0.5D0)
C
      DIMENSION XX(2,NNE),B(NTENS,NDOFEL),P(2,NNE),AUX1(2,NNE),XJ(2,2),
     1          XJI(2,2),SN(NNE)
C
C     Initialize arrays
C
      XBAR=ONE
      CALL CLEAR(B,NTENS,NDOFEL)
      CALL CLEAR(XJ,2,2)
      CALL CLEAR(XJI,2,2)
      CALL CLEAR(P,2,NNE)
C
C     Shape functions and its derivatives w.r.t natural coordinates
C
      CALL SHAPEF8(SN,R,S)
      CALL SFDER8(IELT,NDOFEL,NNE,R,S,P)
C
C     Computes the Jacobian operator and its determinant at point (r,s)
C
      CALL JACOPER(NNE,XJ,XX,P)
      DDET=XJ(1,1)*XJ(2,2)-XJ(1,2)*XJ(2,1)
C
C     Computes the inverse of the Jacobiam operator
C
      CALL JACINVE(XJ,DDET,XJI)
C
C     Jacobian Inverse times Shape Functions derivatives w.r.t natural coordinates
C     to produce shape function derivatives w.r.t x,y coordinates.
C
      CALL MMULT(XJI,2,2,P,2,NNE,AUX1)
C
C     Assembles B matrix for a
C     Full Cosserat element.
C
      DO I=1,NNE
        II=3*(I-1)+1
C
C       Normal components
C
        B(1,II  )= AUX1(1,I)
        B(2,II+1)= AUX1(2,I)
C
C       Shear components
C
        B(4,II+1)= AUX1(1,I)
        B(4,II+2)= SN(I)
        B(5,II  )= AUX1(2,I)
        B(5,II+2)= -SN(I)
C
C       Curvatures
C
        B(6,II+2)= AUX1(1,I)
        B(7,II+2)= AUX1(2,I)
C
      END DO
C
      RETURN
C
      END SUBROUTINE STDM8C
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SHAPE FUNCTIONS AND THEIR DERIVATIVES                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE SFDER9:GENERATES THE SHAPE FUNCTION DERIVATIVES       C
C     ACCORDING TO ELEMENT TYPE AT THE POINT r ,s                      C
C                                             i  j                     C
C     B    =STRAIN-DISPLACEMENT MATRIX                                 C
C     DDET =JACOBIAN DETERMINANT                                       C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SFDER9(IELT,NDOFEL,NNE,R,S,P)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(ONE=1.D0,TWO=2.D0, HALF=0.5D0,QUARTER=0.25D0,FOUR=4.D0)
C
      DIMENSION P(2,NNE)
C
      RP= ONE+R
      SP= ONE+S
      RM= ONE-R
      SM= ONE-S
      RMS=ONE-R**TWO
      SMS=ONE-S**TWO
C
C     9-NODED ELEMENT
C     Derivatives w.r.t the natural coordinates
C     w.r.t.r
C
      P(1,9)=-TWO*R*SMS
      P(1,8)=-HALF*SMS-HALF*P(1,9)
      P(1,7)=-R*SP-HALF*P(1,9)
      P(1,6)= HALF*SMS-HALF*P(1,9)
      P(1,5)=-R*SM-HALF*P(1,9)
      P(1,4)=-QUARTER*SP-HALF*P(1,7)-HALF*P(1,8)-QUARTER*P(1,9)
      P(1,3)= QUARTER*SP-HALF*P(1,7)-HALF*P(1,6)-QUARTER*P(1,9)
      P(1,2)= QUARTER*SM-HALF*P(1,5)-HALF*P(1,6)-QUARTER*P(1,9)
      P(1,1)=-QUARTER*SM-HALF*P(1,8)-HALF*P(1,5)-QUARTER*P(1,9)
C
C        w.r.t.s
C
      P(2,9)=-TWO*S*RMS
      P(2,8)=-S*RM-HALF*P(2,9)
      P(2,7)= HALF*RMS-HALF*P(2,9)
      P(2,6)=-S*RP-HALF*P(2,9)
      P(2,5)=-HALF*RMS-HALF*P(2,9)
      P(2,4)= QUARTER*RM-HALF*P(2,7)-HALF*P(2,8)-QUARTER*P(2,9)
      P(2,3)= QUARTER*RP-HALF*P(2,7)-HALF*P(2,6)-QUARTER*P(2,9)
      P(2,2)=-QUARTER*RP-HALF*P(2,5)-HALF*P(2,6)-QUARTER*P(2,9)
      P(2,1)=-QUARTER*RM-HALF*P(2,8)-HALF*P(2,5)-QUARTER*P(2,9)
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE SFDER8:GENERATES THE SHAPE FUNCTION DERIVATIVES       C
C     ACCORDING TO ELEMENT TYPE AT THE POINT r ,s                      C
C                                             i  j                     C
C     B    =STRAIN-DISPLACEMENT MATRIX                                 C
C     DDET =JACOBIAN DETERMINANT                                       C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SFDER8(IELT,NDOFEL,NNE,R,S,P)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(ONE=1.D0,TWO=2.D0, HALF=0.5D0,QUARTER=0.25D0,FOUR=4.D0)
C
      DIMENSION P(2,NNE)
C
      RP= ONE+R
      SP= ONE+S
      RM= ONE-R
      SM= ONE-S
      RMS=ONE-R**TWO
      SMS=ONE-S**TWO
C
C     8-NODED ELEMENT
C
C     Derivatives w.r.t the natural coordinates
C     w.r.t.r
C
      P(1,6)= HALF*SMS
      P(1,5)=-R*SM
      P(1,8)=-HALF*SMS
      P(1,7)=-R*SP
      P(1,2)= QUARTER*SM-HALF*P(1,5)-HALF*P(1,6)
      P(1,1)=-QUARTER*SM-HALF*P(1,8)-HALF*P(1,5)
      P(1,4)=-QUARTER*SP-HALF*P(1,7)-HALF*P(1,8)
      P(1,3)= QUARTER*SP-HALF*P(1,7)-HALF*P(1,6)
C
C     w.r.t.s
C
      P(2,6)=-S*RP
      P(2,5)=-HALF*RMS
      P(2,8)=-S*RM
      P(2,7)= HALF*RMS
      P(2,2)=-QUARTER*RP-HALF*P(2,5)-HALF*P(2,6)
      P(2,1)=-QUARTER*RM-HALF*P(2,8)-HALF*P(2,5)
      P(2,4)= QUARTER*RM-HALF*P(2,7)-HALF*P(2,8)
      P(2,3)= QUARTER*RP-HALF*P(2,7)-HALF*P(2,6)
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE SFDER6:GENERATES THE SHAPE FUNCTION DERIVATIVES       C
C     ACCORDING TO ELEMENT TYPE AT THE POINT r ,s                      C
C                                             i  j                     C
C     B    =STRAIN-DISPLACEMENT MATRIX                                 C
C     DDET =JACOBIAN DETERMINANT                                       C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SFDER6(IELT,NDOFEL,NNE,R,S,P)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(ONE=1.D0,TWO=2.D0,THREE=3.0D0, HALF=0.5D0,
     1          QUARTER=0.25D0,FOUR=4.D0,EIGHT=8.0D0, ZERO=0.0D0)
C
      DIMENSION P(2,NNE)
C
C     6-NODED ELEMENT
C
C     Derivatives w.r.t the natural coordinates
C     w.r.t.r
C
      P(1,6)=-FOUR*S
      P(1,5)= FOUR*S
      P(1,4)= FOUR-EIGHT*R-FOUR*S
      P(1,3)= ZERO
      P(1,2)= FOUR*R-ONE
      P(1,1)=-THREE+FOUR*R+FOUR*S
C
C     w.r.t.s
C
      P(2,6)= FOUR-FOUR*R-EIGHT*S
      P(2,5)= FOUR*R
      P(2,4)=-FOUR*R
      P(2,3)= FOUR*S-ONE
      P(2,2)= ZERO
      P(2,1)=-THREE+FOUR*R+FOUR*S
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE SHAPEF9(SN,R,S)                                      C
C      9-noded element shape function at point R,S                     C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SHAPEF9(SN,R,S)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ONE=1.0D0,HALF=0.5D0,QUART=0.25D0)
C
      DIMENSION SN(9)
C
      CALL CLEARV(SN,9)
C
      RP =ONE+R
      RM =ONE-R
      RMS=ONE-R*R
      SP =ONE+S
      SM =ONE-S
      SMS=ONE-S*S
C
      SN(9)=RMS*SMS
      SN(8)=HALF*SMS*RM-HALF*SN(9)
      SN(7)=HALF*RMS*SP-HALF*SN(9)
      SN(6)=HALF*SMS*RP-HALF*SN(9)
      SN(5)=HALF*RMS*SM-HALF*SN(9)
      SN(1)=QUART*RM*SM-HALF*SN(8)-HALF*SN(5)-QUART*SN(9)
      SN(2)=QUART*RP*SM-HALF*SN(6)-HALF*SN(5)-QUART*SN(9)
      SN(3)=QUART*RP*SP-HALF*SN(6)-HALF*SN(7)-QUART*SN(9)
      SN(4)=QUART*RM*SP-HALF*SN(8)-HALF*SN(7)-QUART*SN(9)
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE SHAPEF8(SN,R,S)                                      C
C      8-noded element shape function at point R,S                     C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE SHAPEF8(SN,R,S)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ONE=1.0D0,HALF=0.5D0,QUART=0.25D0)
C
      DIMENSION SN(8)
C
      CALL CLEARV(SN,8)
C
      RP =ONE+R
      RM =ONE-R
      RMS=ONE-R*R
      SP =ONE+S
      SM =ONE-S
      SMS=ONE-S*S
C
      SN(8)=HALF*SMS*RM
      SN(7)=HALF*RMS*SP
      SN(6)=HALF*SMS*RP
      SN(5)=HALF*RMS*SM
      SN(1)=QUART*RM*SM-HALF*SN(8)-HALF*SN(5)
      SN(2)=QUART*RP*SM-HALF*SN(6)-HALF*SN(5)
      SN(3)=QUART*RP*SP-HALF*SN(6)-HALF*SN(7)
      SN(4)=QUART*RM*SP-HALF*SN(8)-HALF*SN(7)
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE KJACOPER                                                C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE JACOPER(NNE,XJA,XCORD,RDER)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(ZERO=0.0D0)
C
      DIMENSION XJA(2,2),XCORD(2,NNE),RDER(2,NNE)
C
      CALL CLEAR(XJA,2,2)
C
      DUM=ZERO
      DO K=1,2
        DO J=1,2
          DO I=1,NNE
            DUM=DUM+RDER(K,I)*XCORD(J,I)
          END DO
          XJA(K,J)=DUM
          DUM=ZERO
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      2X2 Jacobian inverse                                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE JACINVE(XJA,DD,XJAI)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION XJA(2,2),XJAI(2,2),XADJ(2,2)
C
      XADJ(1,1)=XJA(2,2)
      XADJ(1,2)=XJA(1,2)
      XADJ(2,1)=XJA(2,1)
      XADJ(2,2)=XJA(1,1)
      DO J=1,2
        DO K=1,2
          COFA=((-1)**(J+K))*XADJ(J,K)
          XJAI(J,K)=COFA/DD
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C                     MASS- MATRICES                                   C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE CMASS8(MASS,NDOFEL,RII,SII)                          C
C      Computes the mass matrix for an 8-noded element                 C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE RMASS8(RMASS,NDOFEL,RII,SII)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (NTENS=2)
C
      DIMENSION SF(NTENS,NDOFEL),SFT(NDOFEL,NTENS),SN(8),
     1          RMASS(NDOFEL,NDOFEL)
C
      CALL CLEAR(SF,NTENS,NDOFEL)
      CALL CLEAR(SFT,NDOFEL,NTENS)
      CALL CLEARV(SN,8)
      CALL CLEAR(RMASS,NDOFEL,NDOFEL)
C
      CALL SHAPEF8(SN,RII,SII)
C
      DO I=1,8
        KK=2*I-1
        SF(1,  KK)=SN(I)
        SF(2,KK+1)=SN(I)
      END DO
C
      CALL MTRAN(SF,NTENS,NDOFEL,SFT)
      CALL MMULT(SFT,NDOFEL,NTENS,SF,NTENS,NDOFEL,RMASS)
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE RMASS8C(MASS,NDOFEL,RII,SII)                          C
C      Computes the mass matrix for an 8-noded element                 C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE RMASS8C(RMASS,RO,RI,NDOFEL,RII,SII)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (NTENS=3)
C
      DIMENSION SF(NTENS,NDOFEL),SFT(NDOFEL,NTENS),SN(8),
     1          RMASS(NDOFEL,NDOFEL),AUX1(NDOFEL,NDOFEL)
C
      CALL CLEAR(SF,NTENS,NDOFEL)
      CALL CLEAR(SFT,NDOFEL,NTENS)
      CALL CLEARV(SN,8)
      CALL CLEAR(AUX1,NDOFEL,NDOFEL)
      CALL CLEAR(RMASS,NDOFEL,NDOFEL)
C
      CALL SHAPEF8(SN,RII,SII)
C
      SQRRO=DSQRT(RO)
      SQRRI=DSQRT(RI)
C
      DO I=1,8
        KK=3*I-2
        SF(1,  KK)=SQRRO*SN(I)
        SF(2,KK+1)=SQRRO*SN(I)
        SF(3,KK+2)=SQRRI*SN(I)
      END DO
C
      CALL MTRAN(SF,NTENS,NDOFEL,SFT)
      CALL MMULT(SFT,NDOFEL,NTENS,SF,NTENS,NDOFEL,RMASS)
C
      RETURN
C
      END SUBROUTINE RMASS8C
C